--- gforth/Attic/kernal.fs 1996/05/04 18:39:25 1.55 +++ gforth/Attic/kernal.fs 1996/05/13 16:37:00 1.59 @@ -145,17 +145,21 @@ HEX \ name> found 17dec92py +$80 constant alias-mask \ set when the word is not an alias! +$40 constant immediate-mask +$20 constant restrict-mask + : (name>) ( nfa+cell -- cfa ) 1 cells - name>string + cfaligned ; : name> ( nfa -- cfa ) \ gforth cell+ - dup (name>) swap c@ $80 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@ $80 and 0= IF @ THEN - -1 r@ $40 and IF 1- THEN - r> $20 and IF negate THEN ; + 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 @@ -247,16 +251,14 @@ Defer source ( -- addr count ) \ core \ Literal 17dec92py : Literal ( compilation n -- ; run-time -- n ) \ core - state @ IF postpone lit , THEN ; immediate + postpone lit , ; immediate restrict : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth - state @ IF postpone lit A, THEN ; - immediate + postpone lit A, ; immediate restrict : char ( 'char' -- n ) \ core bl word char+ c@ ; : [char] ( compilation 'char' -- ; run-time -- n ) - char postpone Literal ; immediate -' [char] Alias Ascii immediate + char postpone Literal ; immediate restrict : (compile) ( -- ) \ gforth r> dup cell+ >r @ compile, ; @@ -486,11 +488,18 @@ Defer parser Defer name ( -- c-addr count ) \ gforth \ get the next word from the input buffer ' (name) IS name -Defer notfound ( c-addr count -- ) +Defer compiler-notfound ( c-addr count -- ) +Defer interpreter-notfound ( c-addr count -- ) : no.extensions ( addr u -- ) 2drop -&13 bounce ; -' no.extensions IS notfound +' no.extensions IS compiler-notfound +' no.extensions IS interpreter-notfound + +: compile-only ( ... -- ) + -&14 throw ; +Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt? +' compile-only IS interpret-special : interpret ( ?? -- ?? ) \ gforth \ interpret/compile the (rest of the) input buffer @@ -511,14 +520,14 @@ Defer notfound ( c-addr count -- ) IF \ not restricted to compile state? nip nip execute EXIT THEN - -&14 throw + interpret-special exit THEN drop 2dup 2>r snumber? IF 2rdrop ELSE - 2r> notfound + 2r> interpreter-notfound THEN ; ' interpreter IS parser @@ -543,7 +552,7 @@ Defer notfound ( c-addr count -- ) postpone Literal 2drop ELSE - drop notfound + drop compiler-notfound THEN ; : [ ( -- ) \ core left-bracket @@ -948,18 +957,10 @@ Avariable leave-sp leave-stack 3 cells immediate restrict create s"-buffer /line chars allot : S" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ core,file s-quote - [char] " parse - state @ - IF - postpone SLiteral - ELSE - /line min >r s"-buffer r@ cmove - s"-buffer r> - THEN ; immediate + [char] " parse postpone SLiteral ; immediate restrict : ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote - state @ IF postpone (.") ," align - ELSE [char] " parse type THEN ; immediate + postpone (.") ," align ; immediate restrict : ( ( compilation 'ccc' -- ; run-time -- ) \ core,file paren BEGIN >in @ [char] ) parse nip >in @ rot - = @@ -993,12 +994,20 @@ create s"-buffer /line chars allot \ Header states 23feb93py -: flag! ( 8b -- ) - last @ dup 0= abort" last word was headerless" - cell+ tuck c@ xor swap c! ; -: immediate $20 flag! ; -: restrict $40 flag! ; -\ ' noop alias restrict +: cset ( bmask c-addr -- ) + tuck c@ or swap c! ; +: creset ( bmask c-addr -- ) + tuck c@ swap invert and swap c! ; +: ctoggle ( bmask c-addr -- ) + tuck c@ xor swap c! ; + +: lastflags ( -- c-addr ) + \ the address of the flags byte in the last header + \ aborts if the last defined word was headerless + last @ dup 0= abort" last word was headerless" cell+ ; + +: immediate immediate-mask lastflags cset ; +: restrict restrict-mask lastflags cset ; \ Header 23feb93py @@ -1014,14 +1023,16 @@ defer header ( -- ) \ gforth \ puts down string as cstring dup c, here swap chars dup allot move ; -: name, ( "name" -- ) \ gforth - name name-too-short? name-too-long? - string, cfalign ; -: input-stream-header ( "name" -- ) - \ !! this is f83-implementation-dependent - align here last ! -1 A, - name, $80 flag! ; +: header, ( c-addr u -- ) \ gforth + name-too-long? + align here last ! + current @ 1 or A, \ link field; before revealing, it contains the + \ tagged reveal-into wordlist + string, cfalign + alias-mask lastflags cset ; +: input-stream-header ( "name" -- ) + name name-too-short? header, ; : input-stream ( -- ) \ general \ switches back to getting the name from the input stream ; ['] input-stream-header IS (header) ; @@ -1032,11 +1043,7 @@ defer header ( -- ) \ gforth create nextname-buffer 32 chars allot : nextname-header ( -- ) - \ !! f83-implementation-dependent - nextname-buffer count - align here last ! -1 A, - string, cfalign - $80 flag! + nextname-buffer count header, input-stream ; \ the next name is given in the string @@ -1059,7 +1066,9 @@ create nextname-buffer 32 chars allot lastcfa @ ; : Alias ( cfa "name" -- ) \ gforth - Header reveal , $80 flag! ; + Header reveal + alias-mask lastflags creset + dup A, lastcfa ! ; : name>string ( nfa -- addr count ) \ gforth name-to-string cell+ count $1F and ; @@ -1067,7 +1076,7 @@ create nextname-buffer 32 chars allot Create ??? 0 , 3 c, char ? c, char ? c, char ? c, : >name ( cfa -- nfa ) \ gforth to-name $21 cell do - dup i - count $9F and + cfaligned over $80 + = if + dup i - count $9F and + cfaligned over alias-mask + = if i - cell - unloop exit then cell +loop @@ -1094,13 +1103,8 @@ Create ??? 0 , 3 c, char ? c, char ? c, \ DOES> 17mar93py : DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does - state @ - IF - ;-hook postpone (does>) ?struc dodoes, - ELSE - align dodoes, here !does ] - THEN - defstart :-hook ; immediate + ;-hook postpone (does>) ?struc dodoes, + defstart :-hook ; immediate restrict \ Create Variable User Constant 17mar93py @@ -1140,22 +1144,13 @@ Create ??? 0 , 3 c, char ? c, char ? c, \ perform ; : IS ( addr "name" -- ) \ gforth - ' >body - state @ - IF postpone ALiteral postpone ! - ELSE ! - THEN ; immediate + ' >body postpone ALiteral postpone ! ; immediate restrict ' IS Alias TO ( addr "name" -- ) \ core-ext -immediate +immediate restrict : What's ( "name" -- addr ) \ gforth - ' >body - state @ - IF - postpone ALiteral postpone @ - ELSE - @ - THEN ; immediate + ' >body postpone ALiteral postpone @ ; immediate restrict + : Defers ( "name" -- ) \ gforth ' >body @ compile, ; immediate @@ -1179,16 +1174,10 @@ AVariable current ( -- addr ) \ gforth : last? ( -- false / nfa nfa ) last @ ?dup ; -: (reveal) ( -- ) - last? - IF - dup @ 0< - IF - current @ @ over ! current @ ! - ELSE - drop - THEN - THEN ; +: (reveal) ( nfa wid -- ) + ( wid>wordlist-id ) dup >r + @ over ( name>link ) ! + r> ! ; \ object oriented search list 17mar93py @@ -1196,7 +1185,7 @@ AVariable current ( -- addr ) \ gforth struct 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) - 1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field + 1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field 1 cells: field rehash-method \ xt: ( wid -- ) \ \ !! what else end-struct wordlist-map-struct @@ -1208,10 +1197,12 @@ struct 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) end-struct wordlist-struct -: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; +: f83find ( addr len wordlist -- nfa / false ) + ( wid>wordlist-id ) @ (f83find) ; \ Search list table: find reveal -Create f83search ' f83find A, ' (reveal) A, ' drop A, +Create f83search ( -- wordlist-map ) + ' f83find A, ' (reveal) A, ' drop A, Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, AVariable lookup G forth-wordlist lookup T ! @@ -1240,6 +1231,9 @@ G -1 warnings T ! then 2drop 2drop ; +: (sfind) ( c-addr u -- nfa | 0 ) + lookup @ (search-wordlist) ; + : sfind ( c-addr u -- xt n / 0 ) \ gforth lookup @ search-wordlist ; @@ -1250,10 +1244,15 @@ G -1 warnings T ! then ; : reveal ( -- ) \ gforth - last? if - name>string current @ check-shadow - then - current @ wordlist-map @ reveal-method perform ; + last? + if \ the last word has a header + dup ( name>link ) @ 1 and + if \ it is still hidden + dup ( name>link ) @ 1 xor ( nfa wid ) + 2dup >r name>string r> check-shadow ( nfa wid ) + dup wordlist-map @ reveal-method perform + then + then ; : rehash ( wid -- ) dup wordlist-map @ rehash-method perform ; @@ -1261,7 +1260,7 @@ G -1 warnings T ! : ' ( "name" -- addr ) \ core tick name sfind 0= if -&13 bounce then ; : ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick - ' postpone ALiteral ; immediate + ' postpone ALiteral ; immediate restrict \ Input 13feb93py 07 constant #bell ( -- c ) \ gforth @@ -1279,6 +1278,9 @@ G -1 warnings T ! #lf ( sic! ) emit ; \ : backspaces 0 ?DO #bs emit LOOP ; + +Variable ^d-mode -1 ^d-mode ! \ ^d is "EOF" if at beginning of the line + : >string ( span addr pos1 -- span addr pos1 addr2 len ) over 3 pick 2 pick chars /string ; : type-rest ( span addr pos1 -- span addr pos1 back ) @@ -1294,7 +1296,11 @@ G -1 warnings T ! : (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 2 pick 0= IF bye ELSE (ret) THEN ; +: eof ^d-mode @ IF + bye + ELSE 2 pick over <> + IF forw drop (del) ELSE #bell emit THEN 0 + THEN ; Create ctrlkeys ] false false back false eof false forw false @@ -1312,14 +1318,11 @@ defer everychar >r 2over = IF rdrop bell 0 EXIT THEN r> (ins) 0 ; -\ decode should better use a table for control key actions -\ to define keyboard bindings later - : accept ( addr len -- len ) \ core dup 0< IF abs over dup 1 chars - c@ tuck type \ this allows to edit given strings ELSE 0 THEN rot over - BEGIN key decode UNTIL + BEGIN key decode dup ^d-mode ! UNTIL 2drop nip ; \ Output 13feb93py @@ -1574,8 +1577,8 @@ create image-included-files 1 , A, ( po : recurse ( compilation -- ; run-time ?? -- ?? ) \ core lastxt compile, ; immediate restrict -: recursive ( -- ) \ gforth - reveal last off ; immediate +' reveal alias recursive ( -- ) \ gforth + immediate \ */MOD */ 17may93jaw