--- gforth/Attic/kernal.fs 1996/02/19 19:19:34 1.53 +++ gforth/Attic/kernal.fs 1996/05/07 16:15:22 1.57 @@ -453,7 +453,7 @@ hex : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception ?DUP IF - [ here 4 cells ! ] + [ here 9 cells ! ] handler @ rp! r> handler ! r> lp! @@ -492,6 +492,11 @@ Defer notfound ( c-addr count -- ) 2drop -&13 bounce ; ' no.extensions IS 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 BEGIN @@ -511,7 +516,7 @@ 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? @@ -1137,7 +1142,7 @@ Create ??? 0 , 3 c, char ? c, char ? c, \ Create ( -- ) \ ['] noop A, \ DOES> ( ??? ) -\ @ execute ; +\ perform ; : IS ( addr "name" -- ) \ gforth ' >body @@ -1218,7 +1223,7 @@ AVariable lookup G forth-wordlist G forth-wordlist current T ! : (search-wordlist) ( addr count wid -- nfa / false ) - dup wordlist-map @ find-method @ execute ; + dup wordlist-map @ find-method perform ; : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search (search-wordlist) dup IF found THEN ; @@ -1253,10 +1258,10 @@ G -1 warnings T ! last? if name>string current @ check-shadow then - current @ wordlist-map @ reveal-method @ execute ; + current @ wordlist-map @ reveal-method perform ; : rehash ( wid -- ) - dup wordlist-map @ rehash-method @ execute ; + dup wordlist-map @ rehash-method perform ; : ' ( "name" -- addr ) \ core tick name sfind 0= if -&13 bounce then ; @@ -1279,6 +1284,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 +1302,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 @@ -1308,18 +1320,15 @@ defer everychar : decode ( max span addr pos1 key -- max span addr pos2 flag ) everychar dup #del = IF drop #bs THEN \ del is rubout - dup bl < IF cells ctrlkeys + @ execute EXIT THEN + dup bl < IF cells ctrlkeys + perform EXIT THEN >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