File:
[gforth] /
gforth /
see.fs
Revision
1.3:
download - view:
text,
annotated -
select for diffs
Wed Jul 13 19:21:08 1994 UTC (29 years, 8 months ago) by
pazsan
Branches:
MAIN
CVS tags:
HEAD
Moved setjmp from engine to go_forth, because the socalled "globbered"
variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).
Added restrict's functionalitz to cross.fs
removed all occurency of cell+ name>, because the bug in name> is
fixed.
Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.
\ SEE.FS highend SEE for ANSforth 16may93jaw
\ May be cross-compiled
\ I'm sorry. This is really not "forthy" enough.
\ Ideas: Level should be a stack
decimal
\ Screen format words 16may93jaw
VARIABLE C-Output 1 C-Output !
VARIABLE C-Formated 1 C-Formated !
VARIABLE C-Highlight 0 C-Highlight !
VARIABLE C-Clearline 0 C-Clearline !
VARIABLE XPos
VARIABLE YPos
VARIABLE Level
: Format C-Formated @ C-Output @ and
IF dup spaces XPos +! ELSE drop THEN ;
: level+ 7 Level +!
Level @ XPos @ -
dup 0> IF Format ELSE drop THEN ;
: level- -7 Level +! ;
VARIABLE nlflag
DEFER nlcount ' noop IS nlcount
: nl nlflag on ;
: (nl) nlcount
XPos @ Level @ = ?Exit
C-Formated @ IF
C-Output @
IF C-Clearline @ IF 80 XPos @ - spaces
ELSE cr THEN
1 YPos +! 0 XPos !
Level @ spaces
THEN Level @ XPos ! THEN ;
: warp? ( len -- len )
nlflag @ IF (nl) nlflag off THEN
XPos @ over + 79 u> IF (nl) THEN ;
: ctype ( adr len -- )
warp? dup XPos +! C-Output @ IF type ELSE 2drop THEN ;
: cemit 1 warp?
over bl = Level @ XPos @ = and
IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
THEN ;
DEFER .string
[IFDEF] Green
VARIABLE Colors Colors on
: (.string) ( c-addr u n -- )
over warp? drop
Colors @
IF C-Highlight @ ?dup
IF CT@ swap CT@ or
ELSE CT@
THEN
attr! ELSE drop THEN
ctype ct @ attr! ;
[ELSE]
: (.string) ( c-addr u n -- )
drop ctype ;
[THEN]
' (.string) IS .string
: .struc Str# .string ;
\ CODES 15may93jaw
21 CONSTANT RepeatCode
22 CONSTANT AgainCode
23 CONSTANT UntilCode
\ 09 CONSTANT WhileCode
10 CONSTANT ElseCode
11 CONSTANT AheadCode
13 CONSTANT WhileCode2
14 CONSTANT Disable
\ FORMAT WORDS 13jun93jaw
VARIABLE C-Stop
VARIABLE Branches
VARIABLE BranchPointer
VARIABLE SearchPointer
CREATE BranchTable 500 allot
here 3 cells -
ACONSTANT MaxTable
: FirstBranch BranchTable cell+ SearchPointer ! ;
: (BranchAddr?) ( a-addr -- a-addr true | false )
SearchPointer @
BEGIN dup BranchPointer @ u<
WHILE
dup @ 2 pick <>
WHILE 3 cells +
REPEAT
nip dup 3 cells + SearchPointer ! true
ELSE
2drop false
THEN ;
: BranchAddr?
FirstBranch (BranchAddr?) ;
' (BranchAddr?) ALIAS MoreBranchAddr?
: CheckEnd ( a-addr -- true | false )
BranchTable cell+
BEGIN dup BranchPointer @ u<
WHILE
dup @ 2 pick u<=
WHILE 3 cells +
REPEAT
2drop false
ELSE
2drop true
THEN ;
\
\ addrw addrt
\ BEGIN ... WHILE ... AGAIN ... THEN
\ ^ ! ! ^
\ ----------+--------+ !
\ ! !
\ +-------------------+
\
\
: CheckWhile ( a-addrw a-addrt -- true | false )
BranchTable
BEGIN dup BranchPointer @ u<
WHILE dup @ 3 pick u>
over @ 3 pick u< and
IF dup cell+ @ 3 pick u<
IF 2drop drop true EXIT THEN
THEN
3 cells +
REPEAT
2drop drop false ;
: ,Branch ( a-addr -- )
BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow"
!
1 cells BranchPointer +! ;
: Type! ( u -- )
BranchPointer @ 1 cells - ! ;
: Branch! ( a-addr rel -- a-addr )
over + over ,Branch ,Branch 0 ,Branch ;
\ DEFER CheckUntil
VARIABLE NoOutput
VARIABLE C-Pass
0 CONSTANT ScanMode
1 CONSTANT DisplayMode
2 CONSTANT DebugMode
: Scan? ( -- flag ) C-Pass @ 0= ;
: Display? ( -- flag ) C-Pass @ 1 = ;
: Debug? ( -- flag ) C-Pass @ 2 = ;
: back? ( n -- flag ) 0< ;
: ahead? ( n -- flag ) 0> ;
: c-(compile)
Display? IF s" POSTPONE " Com# .string
dup @ look 0= ABORT" SEE: No valid XT"
cell+ count $1F and 0 .string bl cemit
THEN
cell+ ;
: c-lit
Display? IF dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit THEN
cell+ ;
: c-s"
count 2dup + aligned -rot
Display?
IF [char] S cemit [char] " cemit bl cemit 0 .string
[char] " cemit bl cemit
ELSE 2drop
THEN ;
: c-."
count 2dup + aligned -rot
Display?
IF [char] . cemit
[char] " cemit bl cemit 0 .string
[char] " cemit bl cemit
ELSE 2drop
THEN ;
: c-c"
count 2dup + aligned -rot
Display?
IF [char] C cemit [char] " cemit bl cemit 0 .string
[char] " cemit bl cemit
ELSE 2drop
THEN ;
: Forward? ( a-addr true | false -- )
IF dup dup @ swap 1 cells - @ -
Ahead? IF true ELSE drop false THEN
\ only if forward jump
ELSE false THEN ;
: RepeatCheck
IF BEGIN 2dup
1 cells - @ swap dup @ +
u<=
WHILE drop dup cell+
MoreBranchAddr? 0=
UNTIL false
ELSE true
THEN
ELSE false
THEN ;
: c-branch
Scan?
IF dup @ Branch!
dup @ back?
IF \ might be: AGAIN, REPEAT
dup cell+ BranchAddr? Forward?
RepeatCheck
IF RepeatCode Type!
cell+ Disable swap !
ELSE AgainCode Type!
THEN
ELSE dup cell+ BranchAddr? Forward?
IF ElseCode Type! drop
ELSE AheadCode Type!
THEN
THEN
THEN
Display?
IF
dup @ back?
IF \ might be: AGAIN, REPEAT
level- nl
dup cell+ BranchAddr? Forward?
RepeatCheck
IF drop S" REPEAT " .struc nl
ELSE S" AGAIN " .struc nl
THEN
ELSE dup cell+ BranchAddr? Forward?
IF dup cell+ @ WhileCode2 =
IF nl S" ELSE" .struc level+
ELSE level- nl S" ELSE" .struc level+ THEN
cell+ Disable swap !
ELSE S" AHEAD" .struc level+
THEN
THEN
THEN
Debug?
IF dup @ +
ELSE cell+
THEN ;
: MyBranch ( a-addr -- a-addr a-addr2 )
dup @ over +
BranchAddr?
BEGIN
WHILE 1 cells - @
over <>
WHILE dup @ over +
MoreBranchAddr?
REPEAT
SearchPointer @ 3 cells -
ELSE true ABORT" SEE: Table failure"
THEN ;
: DebugBranch
Debug?
IF dup @ over + swap THEN ; \ return 2 different addresses
: c-?branch
Scan?
IF dup @ Branch!
dup @ Back?
IF UntilCode Type! THEN
THEN
Display?
IF dup @ Back?
IF level- nl S" UNTIL " .struc nl
ELSE dup dup @ over +
CheckWhile
IF MyBranch
cell+ dup @ 0=
IF WhileCode2 swap !
ELSE drop THEN
level- nl
S" WHILE" .struc
level+
ELSE nl S" IF" .struc level+
THEN
THEN
THEN
DebugBranch
cell+ ;
: c-do
Display? IF nl S" DO" .struc level+ THEN ;
: c-?do
Display? IF nl S" ?DO" .struc level+ THEN
DebugBranch cell+ ;
: c-for
Display? IF nl S" FOR" .struc level+ THEN ;
: c-next
Display? IF level- nl S" NEXT " .struc nl THEN
DebugBranch cell+ cell+ ;
: c-loop
Display? IF level- nl S" LOOP " .struc nl THEN
DebugBranch cell+ cell+ ;
: c-+loop
Display? IF level- nl S" +LOOP " .struc nl THEN
DebugBranch cell+ cell+ ;
: c-leave
Display? IF S" LEAVE " .struc THEN
Debug? IF dup @ + THEN cell+ ;
: c-?leave
Display? IF S" ?LEAVE " .struc THEN
cell+ DebugBranch swap cell+ swap cell+ ;
: c-exit dup 1 cells -
CheckEnd
IF Display? IF nlflag off S" ;" Com# .string THEN
C-Stop on
ELSE Display? IF S" EXIT " .struc THEN
THEN
Debug? IF drop THEN ;
: c-;code \ end of create part
Display? IF S" DOES> " Com# .string THEN
Cell+ cell+ ;
: c-abort"
count 2dup + aligned -rot
Display?
IF S" ABORT" .struc
[char] " cemit bl cemit 0 .string
[char] " cemit bl cemit
ELSE 2drop
THEN ;
CREATE C-Table
' lit A, ' c-lit A,
' (s") A, ' c-s" A,
' (.") A, ' c-." A,
' "lit A, ' c-c" A,
' ?branch A, ' c-?branch A,
' branch A, ' c-branch A,
' leave A, ' c-leave A,
' ?leave A, ' c-?leave A,
' (do) A, ' c-do A,
' (?do) A, ' c-?do A,
' (for) A, ' c-for A,
' (loop) A, ' c-loop A,
' (+loop) A, ' c-+loop A,
' (next) A, ' c-next A,
' ;s A, ' c-exit A,
' (;code) A, ' c-;code A,
' (abort") A, ' c-abort" A,
' (compile) A, ' c-(compile) A,
0 ,
\ DOTABLE 15may93jaw
: DoTable ( cfa -- flag )
C-Table
BEGIN dup @ dup
WHILE 2 pick <>
WHILE 2 cells +
REPEAT
nip cell+ @ EXECUTE
true
ELSE
2drop drop false
THEN ;
: BranchTo? ( a-addr -- a-addr )
Display? IF dup BranchAddr?
IF BEGIN cell+ @ dup 20 u>
IF drop nl S" BEGIN " .struc level+
ELSE
dup Disable <>
IF WhileCode2 =
IF nl S" THEN " .struc nl ELSE
level- nl S" THEN " .struc nl THEN
ELSE drop THEN
THEN
dup MoreBranchAddr? 0=
UNTIL
THEN
THEN ;
: analyse ( a-addr1 -- a-addr2 )
Branches @ IF BranchTo? THEN
dup cell+ swap @
dup >r DoTable r> swap IF drop EXIT THEN
Display?
IF look 0= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!"
ELSE dup cell+ count 31 and rot wordinfo .string THEN bl cemit
ELSE drop
THEN ;
: c-init
0 YPos ! 0 XPos !
0 Level ! nlflag off
BranchTable BranchPointer !
c-stop off
Branches on ;
: makepass ( a-addr -- )
c-stop off
BEGIN
analyse
c-stop @
UNTIL drop ;
DEFER dosee
: dopri .name ." is primitive" cr ;
: dovar .name ." is variable" cr ;
: docon dup .name ." is constant, value: "
cell+ (name>) >body @ . cr ;
: doval .name ." is value" cr ;
: dodef .name ." is defered word, is: "
here @ look 0= ABORT" SEE: No valid xt in defered word"
.name cr here @ look drop dosee ;
: dodoe .name ." is created word" cr
S" DOES> " Com# .string XPos @ Level !
here @ dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
ScanMode c-pass ! dup makepass
DisplayMode c-pass ! makepass ;
: doali .name ." is alias of "
here @ .name cr
here @ dosee ;
: docol S" : " Com# .string
dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit
( XPos @ ) 2 Level !
name> >body
C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
ScanMode c-pass ! dup makepass
DisplayMode c-pass ! makepass ;
create wordtypes
Pri# , ' dopri A,
Var# , ' dovar A,
Con# , ' docon A,
Val# , ' doval A,
Def# , ' dodef A,
Doe# , ' dodoe A,
Ali# , ' doali A,
Col# , ' docol A,
0 ,
: (dosee) ( lfa -- )
dup dup cell+ c@ 32 and IF over .name ." is an immediate word" cr THEN
wordinfo
wordtypes
BEGIN dup @ dup
WHILE 2 pick = IF cell+ @ nip EXECUTE EXIT THEN
2 cells +
REPEAT
2drop
.name ." Don't know how to handle" cr ;
' (dosee) IS dosee
: xtc ( xt -- ) \ do see at xt
Look 0= ABORT" SEE: No valid XT"
cr c-init
dosee ;
: see name find 0= IF ." Word unknown" cr drop exit THEN
xtc ;
: lfc cr c-init cell+ dosee ;
: nfc cr c-init dosee ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>