version 1.59, 1996/05/13 16:37:00
|
version 1.60, 1996/07/16 20:57:11
|
Line 74 HEX
|
Line 74 HEX
|
\ the code address of a @code{field} |
\ the code address of a @code{field} |
['] reveal-method >code-address ; |
['] reveal-method >code-address ; |
|
|
|
NIL AConstant NIL \ gforth |
|
|
\ Bit string manipulation 06oct92py |
\ Bit string manipulation 06oct92py |
|
|
\ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, |
\ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, |
Line 143 HEX
|
Line 145 HEX
|
: off ( addr -- ) \ gforth |
: off ( addr -- ) \ gforth |
false swap ! ; |
false swap ! ; |
|
|
|
\ dabs roll 17may93jaw |
|
|
|
: dabs ( d1 -- d2 ) \ double |
|
dup 0< IF dnegate THEN ; |
|
|
|
: roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext |
|
dup 1+ pick >r |
|
cells sp@ cell+ dup cell+ rot move drop r> ; |
|
|
\ name> found 17dec92py |
\ name> found 17dec92py |
|
|
$80 constant alias-mask \ set when the word is not an alias! |
$80 constant alias-mask \ set when the word is not an alias! |
Line 155 $20 constant restrict-mask
|
Line 166 $20 constant restrict-mask
|
cell+ |
cell+ |
dup (name>) swap c@ alias-mask and 0= IF @ THEN ; |
dup (name>) swap c@ alias-mask and 0= IF @ THEN ; |
|
|
: found ( nfa -- cfa n ) \ gforth |
|
cell+ |
|
dup c@ >r (name>) r@ alias-mask and 0= IF @ THEN |
|
-1 r@ restrict-mask and IF 1- THEN |
|
r> immediate-mask and IF negate THEN ; |
|
|
|
\ (find) 17dec92py |
\ (find) 17dec92py |
|
|
\ : (find) ( addr count nfa1 -- nfa2 / false ) |
\ : (find) ( addr count nfa1 -- nfa2 / false ) |
Line 264 Defer source ( -- addr count ) \ core
|
Line 269 Defer source ( -- addr count ) \ core
|
r> dup cell+ >r @ compile, ; |
r> dup cell+ >r @ compile, ; |
: postpone ( "name" -- ) \ core |
: postpone ( "name" -- ) \ core |
name sfind dup 0= abort" Can't compile " |
name sfind dup 0= abort" Can't compile " |
0> IF compile, ELSE postpone (compile) A, THEN ; |
0> IF compile, ELSE postpone (compile) A, THEN ; immediate restrict |
immediate restrict |
|
|
: special: ( interp comp "name" -- ) |
|
Create immediate swap A, A, |
|
DOES> state @ IF cell+ THEN perform ; |
|
|
\ Use (compile) for the old behavior of compile! |
\ Use (compile) for the old behavior of compile! |
|
|
Line 514 Defer interpret-special ( c-addr u xt --
|
Line 522 Defer interpret-special ( c-addr u xt --
|
|
|
: interpreter ( c-addr u -- ) \ gforth |
: interpreter ( c-addr u -- ) \ gforth |
\ interpretation semantics for the name/number c-addr u |
\ interpretation semantics for the name/number c-addr u |
2dup sfind dup |
2dup (sfind) dup |
IF |
IF |
1 and |
1 and |
IF \ not restricted to compile state? |
IF \ not restricted to compile state? |
Line 534 Defer interpret-special ( c-addr u xt --
|
Line 542 Defer interpret-special ( c-addr u xt --
|
|
|
: compiler ( c-addr u -- ) \ gforth |
: compiler ( c-addr u -- ) \ gforth |
\ compilation semantics for the name/number c-addr u |
\ compilation semantics for the name/number c-addr u |
2dup sfind dup |
2dup (sfind) dup |
IF |
IF |
0> |
0> |
IF |
IF |
Line 738 variable backedge-locals
|
Line 746 variable backedge-locals
|
: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if |
: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if |
POSTPONE ?dup-0=-?branch >mark ; immediate restrict |
POSTPONE ?dup-0=-?branch >mark ; immediate restrict |
|
|
: THEN ( compilation orig -- ; run-time -- ) \ core |
: then-like ( orig -- addr ) |
dup orig? |
swap -rot dead-orig = |
dead-orig = |
|
if |
if |
>resolve drop |
drop |
else |
else |
dead-code @ |
dead-code @ |
if |
if |
>resolve set-locals-size-list dead-code off |
set-locals-size-list dead-code off |
else \ both live |
else \ both live |
over list-size adjust-locals-size |
dup list-size adjust-locals-size |
>resolve |
|
locals-list @ common-list dup list-size adjust-locals-size |
locals-list @ common-list dup list-size adjust-locals-size |
locals-list ! |
locals-list ! |
then |
then |
then ; immediate restrict |
then ; |
|
|
|
: THEN ( compilation orig -- ; run-time -- ) \ core |
|
dup orig? then-like >resolve ; immediate restrict |
|
|
' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth |
' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth |
immediate restrict |
immediate restrict |
Line 782 immediate restrict
|
Line 791 immediate restrict
|
\ issue a warning (see below). The following code is generated: |
\ issue a warning (see below). The following code is generated: |
\ lp+!# (current-local-size - dest-locals-size) |
\ lp+!# (current-local-size - dest-locals-size) |
\ branch <begin> |
\ branch <begin> |
: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext |
|
dest? |
: again-like ( dest -- addr ) |
over list-size adjust-locals-size |
over list-size adjust-locals-size |
POSTPONE branch |
swap check-begin POSTPONE unreachable ; |
<resolve |
|
check-begin |
: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext |
POSTPONE unreachable ; immediate restrict |
dest? again-like POSTPONE branch <resolve ; immediate restrict |
|
|
\ UNTIL (the current control flow may join an earlier one or continue): |
\ UNTIL (the current control flow may join an earlier one or continue): |
\ Similar to AGAIN. The new locals-list and locals-size are the current |
\ Similar to AGAIN. The new locals-list and locals-size are the current |
Line 955 Avariable leave-sp leave-stack 3 cells
|
Line 964 Avariable leave-sp leave-stack 3 cells
|
: SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string |
: SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string |
postpone (S") here over char+ allot place align ; |
postpone (S") here over char+ allot place align ; |
immediate restrict |
immediate restrict |
create s"-buffer /line chars allot |
|
: S" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ core,file s-quote |
|
[char] " parse postpone SLiteral ; immediate restrict |
|
|
|
: ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote |
|
postpone (.") ," align ; immediate restrict |
|
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren |
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren |
BEGIN |
BEGIN |
>in @ [char] ) parse nip >in @ rot - = |
>in @ [char] ) parse nip >in @ rot - = |
Line 1100 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 1103 Create ??? 0 , 3 c, char ? c, char ? c,
|
: Create ( -- ) \ core |
: Create ( -- ) \ core |
Header reveal dovar: cfa, ; |
Header reveal dovar: cfa, ; |
|
|
\ DOES> 17mar93py |
|
|
|
: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does |
|
;-hook postpone (does>) ?struc dodoes, |
|
defstart :-hook ; immediate restrict |
|
|
|
\ Create Variable User Constant 17mar93py |
\ Create Variable User Constant 17mar93py |
|
|
: Variable ( -- ) \ core |
: Variable ( -- ) \ core |
Line 1143 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 1140 Create ??? 0 , 3 c, char ? c, char ? c,
|
\ DOES> ( ??? ) |
\ DOES> ( ??? ) |
\ perform ; |
\ perform ; |
|
|
: IS ( addr "name" -- ) \ gforth |
|
' >body postpone ALiteral postpone ! ; immediate restrict |
|
' IS Alias TO ( addr "name" -- ) \ core-ext |
|
immediate restrict |
|
|
|
: What's ( "name" -- addr ) \ gforth |
|
' >body postpone ALiteral postpone @ ; immediate restrict |
|
|
|
: Defers ( "name" -- ) \ gforth |
: Defers ( "name" -- ) \ gforth |
' >body @ compile, ; immediate |
' >body @ compile, ; immediate |
|
|
Line 1208 Create forth-wordlist NIL A, G f83searc
|
Line 1197 Create forth-wordlist NIL A, G f83searc
|
AVariable lookup G forth-wordlist lookup T ! |
AVariable lookup G forth-wordlist lookup T ! |
G forth-wordlist current T ! |
G forth-wordlist current T ! |
|
|
|
\ higher level parts of find |
|
|
|
: special? ( xt -- flag ) |
|
>does-code ['] S" >does-code = ; |
|
|
|
: xt>i ( xt -- xt ) |
|
dup special? IF >body @ THEN ; |
|
|
|
: xt>c ( xt -- xt ) |
|
dup special? IF >body cell+ @ THEN ; |
|
|
|
: xt>s ( xt -- xt ) |
|
dup special? IF >body state @ IF cell+ THEN @ THEN ; |
|
|
|
: found ( nfa -- cfa n ) \ gforth |
|
cell+ dup c@ >r (name>) |
|
r@ alias-mask and 0= IF @ THEN -1 |
|
r@ restrict-mask and IF 1- THEN |
|
r> immediate-mask and IF negate THEN ; |
|
|
: (search-wordlist) ( addr count wid -- nfa / false ) |
: (search-wordlist) ( addr count wid -- nfa / false ) |
dup wordlist-map @ find-method perform ; |
dup wordlist-map @ find-method perform ; |
|
|
: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
(search-wordlist) dup IF found THEN ; |
(search-wordlist) dup IF found swap xt>s swap THEN ; |
|
|
|
: (sfind) ( c-addr u -- xt n / 0 ) |
|
lookup @ (search-wordlist) dup IF found THEN ; |
|
|
|
: sfind ( c-addr u -- xt n / 0 ) \ gforth |
|
lookup @ search-wordlist ; |
|
|
|
: find ( addr -- cfa +-1 / string false ) \ core,search |
|
dup count sfind dup IF |
|
rot drop |
|
THEN |
|
dup 1 and 0= IF 2/ THEN ; |
|
|
|
: (') ( "name" -- xt ) \ gforth paren-tick |
|
name (sfind) 0= IF -&13 bounce THEN ; |
|
: [(')] ( compilation "name" -- ; run-time -- addr ) \ gforth bracket-paren-tick |
|
(') postpone ALiteral ; immediate restrict |
|
|
|
: ' ( "name" -- xt ) \ core tick |
|
(') xt>i ; |
|
: ['] ( compilation "name" -- ; run-time -- addr ) \ core bracket-tick |
|
' postpone ALiteral ; immediate restrict |
|
|
|
: C' ( "name" -- xt ) \ gforth c-tick |
|
(') xt>c ; |
|
: [C'] ( compilation "name" -- ; run-time -- addr ) \ gforth bracket-c-tick |
|
C' postpone ALiteral ; immediate restrict |
|
|
|
: S' ( "name" -- xt ) \ gforth s-tick |
|
(') xt>s ; |
|
: [S'] ( compilation "name" -- ; run-time -- addr ) \ gforth bracket-s-tick |
|
S' postpone ALiteral ; immediate restrict |
|
|
|
\ reveal words |
|
|
Variable warnings ( -- addr ) \ gforth |
Variable warnings ( -- addr ) \ gforth |
G -1 warnings T ! |
G -1 warnings T ! |
|
|
: check-shadow ( addr count wid -- ) |
: check-shadow ( addr count wid -- ) |
\ prints a warning if the string is already present in the wordlist |
\ prints a warning if the string is already present in the wordlist |
\ !! should be refined so the user can suppress the warnings |
|
>r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if |
>r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if |
." redefined " name>string 2dup type |
." redefined " name>string 2dup type |
compare 0<> if |
compare 0<> if |
Line 1231 G -1 warnings T !
|
Line 1273 G -1 warnings T !
|
then |
then |
2drop 2drop ; |
2drop 2drop ; |
|
|
: (sfind) ( c-addr u -- nfa | 0 ) |
|
lookup @ (search-wordlist) ; |
|
|
|
: sfind ( c-addr u -- xt n / 0 ) \ gforth |
|
lookup @ search-wordlist ; |
|
|
|
: find ( addr -- cfa +-1 / string false ) \ core,search |
|
\ !! not ANS conformant: returns +-2 for restricted words |
|
dup count sfind dup if |
|
rot drop |
|
then ; |
|
|
|
: reveal ( -- ) \ gforth |
: reveal ( -- ) \ gforth |
last? |
last? |
if \ the last word has a header |
if \ the last word has a header |
Line 1257 G -1 warnings T !
|
Line 1287 G -1 warnings T !
|
: rehash ( wid -- ) |
: rehash ( wid -- ) |
dup wordlist-map @ rehash-method perform ; |
dup wordlist-map @ rehash-method perform ; |
|
|
: ' ( "name" -- addr ) \ core tick |
|
name sfind 0= if -&13 bounce then ; |
|
: ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick |
|
' postpone ALiteral ; immediate restrict |
|
\ Input 13feb93py |
\ Input 13feb93py |
|
|
07 constant #bell ( -- c ) \ gforth |
07 constant #bell ( -- c ) \ gforth |
Line 1279 G -1 warnings T !
|
Line 1305 G -1 warnings T !
|
|
|
\ : backspaces 0 ?DO #bs emit LOOP ; |
\ : backspaces 0 ?DO #bs emit LOOP ; |
|
|
Variable ^d-mode -1 ^d-mode ! \ ^d is "EOF" if at beginning of the line |
: (ins) ( max span addr pos1 key -- max span addr pos2 ) |
|
>r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ; |
: >string ( span addr pos1 -- span addr pos1 addr2 len ) |
: (bs) ( max span addr pos1 -- max span addr pos2 flag ) |
over 3 pick 2 pick chars /string ; |
dup IF |
: type-rest ( span addr pos1 -- span addr pos1 back ) |
#bs emit bl emit #bs emit 1- rot 1- -rot |
>string tuck type ; |
THEN false ; |
: (del) ( max span addr pos1 -- max span addr pos2 ) |
: (ret) true space ; |
1- >string over 1+ -rot move |
|
rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ; |
|
: (ins) ( max span addr pos1 char -- max span addr pos2 ) |
|
>r >string over 1+ swap move 2dup chars + r> swap c! |
|
rot 1+ -rot type-rest 1- backspaces 1+ ; |
|
: ?del ( max span addr pos1 -- max span addr pos2 0 ) |
|
dup IF (del) THEN 0 ; |
|
: (ret) type-rest drop true space ; |
|
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; |
|
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; |
|
: eof ^d-mode @ IF |
|
bye |
|
ELSE 2 pick over <> |
|
IF forw drop (del) ELSE #bell emit THEN 0 |
|
THEN ; |
|
|
|
Create ctrlkeys |
Create ctrlkeys |
] false false back false eof false forw false |
] false false false false false false false false |
?del false (ret) false false (ret) false false |
(bs) false (ret) false false (ret) false false |
false false false false false false false false |
false false false false false false false false |
false false false false false false false false [ |
false false false false false false false false [ |
|
|
|
defer insert-char |
|
' (ins) IS insert-char |
defer everychar |
defer everychar |
' noop IS everychar |
' noop IS everychar |
|
|
Line 1316 defer everychar
|
Line 1329 defer everychar
|
dup #del = IF drop #bs THEN \ del is rubout |
dup #del = IF drop #bs THEN \ del is rubout |
dup bl < IF cells ctrlkeys + perform EXIT THEN |
dup bl < IF cells ctrlkeys + perform EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
r> (ins) 0 ; |
r> insert-char 0 ; |
|
|
: accept ( addr len -- len ) \ core |
: accept ( addr len -- len ) \ core |
dup 0< IF abs over dup 1 chars - c@ tuck type |
dup 0< IF abs over dup 1 chars - c@ tuck type |
\ this allows to edit given strings |
\ this allows to edit given strings |
ELSE 0 THEN rot over |
ELSE 0 THEN rot over |
BEGIN key decode dup ^d-mode ! UNTIL |
BEGIN key decode UNTIL |
2drop nip ; |
2drop nip ; |
|
|
\ Output 13feb93py |
\ Output 13feb93py |
Line 1439 create pathfilenamebuf 256 chars allot \
|
Line 1452 create pathfilenamebuf 256 chars allot \
|
\ ELSE false |
\ ELSE false |
\ THEN ; |
\ THEN ; |
|
|
|
: absolut-path? ( addr u -- flag ) \ gforth |
|
\ a path is absolute, if it starts with a / or a ~ (~ expansion), |
|
\ or if it is in the form ./* or ../*, extended regexp: [/~]|./|../ |
|
\ Pathes simply containing a / are not absolute! |
|
over c@ '/ = >r |
|
over c@ '~ = >r |
|
2dup 2 min S" ./" compare 0= >r |
|
3 min S" ../" compare 0= |
|
r> r> r> or or or ; |
|
\ [char] / scan nip 0<> ; |
|
|
: open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth |
: open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth |
\ opens a file for reading, searching in the path for it (unless |
\ opens a file for reading, searching in the path for it (unless |
\ the filename contains a slash); c-addr2 u2 is the full filename |
\ the filename contains a slash); c-addr2 u2 is the full filename |
Line 1448 create pathfilenamebuf 256 chars allot \
|
Line 1472 create pathfilenamebuf 256 chars allot \
|
\ the path will usually contain dirs that are only readable for |
\ the path will usually contain dirs that are only readable for |
\ the user |
\ the user |
\ !! use file-status to determine access mode? |
\ !! use file-status to determine access mode? |
2dup [char] / scan nip ( 0<> ) |
2dup absolut-path? |
if \ the filename contains a slash |
if \ the filename contains a slash |
2dup r/o open-file throw ( c-addr1 u1 file-id ) |
2dup r/o open-file throw ( c-addr1 u1 file-id ) |
-rot >r pathfilenamebuf r@ cmove ( file-id R: u1 ) |
-rot >r pathfilenamebuf r@ cmove ( file-id R: u1 ) |
Line 1812 Defer 'cold ' noop IS 'cold
|
Line 1836 Defer 'cold ' noop IS 'cold
|
\ or space and stackspace overrides |
\ or space and stackspace overrides |
|
|
\ 0 arg contains, however, the name of the program. |
\ 0 arg contains, however, the name of the program. |
|
|
|
|