--- gforth/Attic/kernal.fs 1994/09/12 19:00:32 1.20 +++ gforth/Attic/kernal.fs 1995/02/09 17:49:57 1.29 @@ -1,4 +1,4 @@ -\ KERNAL.FS ANS figFORTH kernal 17dec92py +\ KERNAL.FS GNU FORTH kernal 17dec92py \ $ID: \ Idea and implementation: Bernd Paysan (py) \ Copyright 1992 by the ANSI figForth Development Group @@ -66,7 +66,16 @@ DOES> ( n -- ) + c@ ; bl c, LOOP ; +\ !! this is machine-dependent, but works on all but the strangest machines +' faligned Alias maxaligned +' falign Alias maxalign + +\ the code field is aligned if its body is maxaligned +\ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned" +' maxaligned Alias cfaligned +' maxalign Alias cfalign +: chars ; immediate : A! ( addr1 addr2 -- ) dup relon ! ; : A, ( addr -- ) here cell allot A! ; @@ -78,9 +87,11 @@ DOES> ( n -- ) + c@ ; \ name> found 17dec92py -: (name>) ( nfa -- cfa ) count $1F and + aligned ; -: name> ( nfa -- cfa ) cell+ - dup (name>) swap c@ $80 and 0= IF @ THEN ; +: (name>) ( nfa -- cfa ) + count $1F and + cfaligned ; +: name> ( nfa -- cfa ) + cell+ + dup (name>) swap c@ $80 and 0= IF @ THEN ; : found ( nfa -- cfa n ) cell+ dup c@ >r (name>) r@ $80 and 0= IF @ THEN @@ -173,10 +184,10 @@ Defer source : [char] ( 'char' -- n ) char postpone Literal ; immediate ' [char] Alias Ascii immediate -: (compile) ( -- ) r> dup cell+ >r @ A, ; +: (compile) ( -- ) r> dup cell+ >r @ compile, ; : postpone ( "name" -- ) name sfind dup 0= abort" Can't compile " - 0> IF A, ELSE postpone (compile) A, THEN ; + 0> IF compile, ELSE postpone (compile) A, THEN ; immediate restrict \ Use (compile) for the old behavior of compile! @@ -244,6 +255,9 @@ decimal Create spaces bl 80 times \ times from target compiler! 11may93jaw DOES> ( u -- ) swap 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; +Create backspaces 08 80 times \ times from target compiler! 11may93jaw +DOES> ( u -- ) swap + 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; hex : space 1 spaces ; @@ -355,7 +369,7 @@ Defer notfound ( c-addr count -- ) IF 1 and IF \ not restricted to compile state? - nip nip execute EXIT + nip nip execute EXIT THEN -&14 throw THEN @@ -417,11 +431,23 @@ AConstant locals-list \ acts like a vari variable dead-code \ true if normal code at "here" would be dead - -: unreachable ( -- ) -\ declares the current point of execution as unreachable - dead-code on ; - +variable backedge-locals + \ contains the locals list that BEGIN will assume to be live on + \ the back edge if the BEGIN is unreachable from above. Set by + \ ASSUME-LIVE, reset by UNREACHABLE. + +: UNREACHABLE ( -- ) + \ declares the current point of execution as unreachable + dead-code on + 0 backedge-locals ! ; immediate + +: ASSUME-LIVE ( orig -- orig ) + \ used immediateliy before a BEGIN that is not reachable from + \ above. causes the BEGIN to assume that the same locals are live + \ as at the orig point + dup orig? + 2 pick backedge-locals ! ; immediate + \ locals list operations : common-list ( list1 list2 -- list3 ) @@ -546,7 +572,7 @@ variable dead-code \ true if normal code \ Structural Conditionals 12dec92py : AHEAD ( -- orig ) - POSTPONE branch >mark unreachable ; immediate restrict + POSTPONE branch >mark POSTPONE unreachable ; immediate restrict : IF ( -- orig ) POSTPONE ?branch >mark ; immediate restrict @@ -588,17 +614,10 @@ variable dead-code \ true if normal code : BEGIN ( -- dest ) dead-code @ if - \ set up an assumption of the locals visible here - \ currently we just take the top cs-item - \ it would be more intelligent to take the top orig - \ but that can be arranged by the user - dup defstart <> if - dup cs-item? - 2 pick - else - 0 - then - set-locals-size-list + \ set up an assumption of the locals visible here. if the + \ users want something to be visible, they have to declare + \ that using ASSUME-LIVE + backedge-locals @ set-locals-size-list then cs-push-part dest dead-code off ; immediate restrict @@ -614,7 +633,7 @@ variable dead-code \ true if normal code POSTPONE branch r drop +: DONE ( orig -- ) \ !! the original done had ( addr -- ) + drop >r drop begin leave> over r@ u>= @@ -746,7 +766,7 @@ Avariable leave-sp leave-stack 3 cells : EXIT ( -- ) 0 adjust-locals-size POSTPONE ;s - unreachable ; immediate restrict + POSTPONE unreachable ; immediate restrict : ?EXIT ( -- ) POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict @@ -794,10 +814,14 @@ Avariable leave-sp leave-stack 3 cells defer (header) defer header ' (header) IS header +: string, ( c-addr u -- ) + \ puts down string as cstring + dup c, here swap chars dup allot move ; + : name, ( "name" -- ) name dup $1F u> -&19 and throw ( is name too long? ) - dup c, here swap chars dup allot move align ; + string, cfalign ; : input-stream-header ( "name" -- ) \ !! this is f83-implementation-dependent align here last ! -1 A, @@ -816,7 +840,7 @@ create nextname-buffer 32 chars allot \ !! f83-implementation-dependent nextname-buffer count align here last ! -1 A, - dup c, here swap chars dup allot move align + string, cfalign $80 flag! input-stream ; @@ -828,7 +852,7 @@ create nextname-buffer 32 chars allot ['] nextname-header IS (header) ; : noname-header ( -- ) - 0 last ! + 0 last ! cfalign input-stream ; : noname ( -- ) \ general @@ -848,7 +872,7 @@ create nextname-buffer 32 chars allot Create ??? 0 , 3 c, char ? c, char ? c, char ? c, : >name ( cfa -- nfa ) $21 cell do - dup i - count $9F and + aligned over $80 + = if + dup i - count $9F and + cfaligned over $80 + = if i - cell - unloop exit then cell +loop @@ -984,7 +1008,7 @@ G forth-wordlist current T ! dup cell+ @ @ execute ; : search-wordlist ( addr count wid -- 0 / xt +-1 ) - (search-wordlist) dup IF found THEN ; + (search-wordlist) dup IF found THEN ; Variable warnings G -1 warnings T ! @@ -1033,7 +1057,7 @@ Variable warnings G -1 warnings T ! : bell #bell emit ; -: backspaces 0 ?DO #bs emit LOOP ; +\ : backspaces 0 ?DO #bs emit LOOP ; : >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 ) @@ -1050,15 +1074,19 @@ Variable warnings G -1 warnings T ! : 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 ; -Create crtlkeys +Create ctrlkeys ] false false back false false false forw false ?del false (ret) false false (ret) false false false false false false false false false false false false false false false false false false [ +defer everychar +' noop IS 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 crtlkeys + @ execute EXIT THEN + dup bl < IF cells ctrlkeys + @ execute EXIT THEN >r 2over = IF rdrop bell 0 EXIT THEN r> (ins) 0 ; @@ -1185,15 +1213,57 @@ create pathfilenamebuf 256 chars allot \ 0<> -&38 and throw ( file-id u2 ) pathfilenamebuf swap ; -: included ( i*x addr u -- j*x ) +create included-files 0 , 0 , ( pointer to and count of included files ) + +: included? ( c-addr u -- f ) + \ true, iff filename c-addr u is in included-files + included-files 2@ 0 + ?do ( c-addr u addr ) + dup >r 2@ 2over compare 0= + if + 2drop rdrop unloop + true EXIT + then + r> cell+ cell+ + loop + 2drop drop false ; + +: add-included-file ( c-addr u -- ) + \ add name c-addr u to included-files + included-files 2@ tuck 1+ 2* cells resize throw + swap 2dup 1+ included-files 2! + 2* cells + 2! ; + +: save-string ( addr1 u -- addr2 u ) + swap >r + dup allocate throw + swap 2dup r> -rot move ; + +: included1 ( i*x file-id c-addr u -- j*x ) + \ include the file file-id with the name given by c-addr u loadfilename 2@ >r >r - open-path-file ( file-id c-addr2 u2 ) - dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 ) - drop loadfilename 2@ move + save-string 2dup loadfilename 2! add-included-file ( file-id ) ['] include-file catch - \ don't free filenames; they don't take much space - \ and are used for debugging r> r> loadfilename 2! throw ; + +: included ( i*x addr u -- j*x ) + open-path-file included1 ; + +: required ( i*x addr u -- j*x ) + \ include the file with the name given by addr u, if it is not + \ included already. Currently this works by comparing the name of + \ the file (with path) against the names of earlier included + \ files; however, it would probably be better to fstat the file, + \ and compare the device and inode. The advantages would be: no + \ problems with several paths to the same file (e.g., due to + \ links) and we would catch files included with include-file and + \ write a require-file. + open-path-file 2dup included? + if + 2drop close-file throw + else + included1 + then ; \ HEX DECIMAL 2may93jaw @@ -1203,12 +1273,16 @@ create pathfilenamebuf 256 chars allot \ \ DEPTH 9may93jaw : depth ( -- +n ) sp@ s0 @ swap - cell / ; +: clearstack ( ... -- ) s0 @ sp! ; \ INCLUDE 9may93jaw : include ( "file" -- ) name included ; +: require ( "file" -- ) + name required ; + \ RECURSE 17may93jaw : recurse ( -- ) @@ -1372,15 +1446,15 @@ Variable argc 2drop here r> tuck - 2 cells / ; -: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; - : do-option ( addr1 len1 addr2 len2 -- n ) 2swap 2dup s" -e" compare 0= >r 2dup s" -evaluate" compare 0= r> or - IF 2drop ">tib interpret 2 EXIT THEN + IF 2drop dup >r ['] evaluate catch + ?dup IF dup >r DoError r> negate (bye) THEN + r> >tib +! 2 EXIT THEN ." Unknown option: " type cr 2drop 1 ; -: process-args ( -- ) +: process-args ( -- ) >tib @ >r argc @ 1 ?DO I arg over c@ [char] - <> @@ -1389,10 +1463,14 @@ Variable argc ELSE I 1+ arg do-option THEN - +LOOP ; + +LOOP + r> >tib ! ; + +Defer 'cold ' noop IS 'cold : cold ( -- ) pathstring 2@ process-path pathdirs 2! + 'cold argc @ 1 > IF ['] process-args catch ?dup @@ -1404,7 +1482,7 @@ Variable argc ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr ." Type `bye' to exit" - quit ; + loadline off quit ; : license ( -- ) cr ." This program is free software; you can redistribute it and/or modify" cr @@ -1423,7 +1501,8 @@ Variable argc : boot ( path **argv argc -- ) argc ! argv ! cstring>sstring pathstring 2! main-task up! - sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; + sp@ dup s0 ! $10 + >tib ! #tib off >in off + rp@ r0 ! fp@ f0 ! cold ; : bye script? 0= IF cr THEN 0 (bye) ;