--- gforth/Attic/kernel.fs 1996/10/02 09:48:58 1.6 +++ gforth/Attic/kernel.fs 1997/02/01 14:59:31 1.12 @@ -20,32 +20,6 @@ \ Idea and implementation: Bernd Paysan (py) -\ Log: ', '- usw. durch [char] ... ersetzt -\ man sollte die unterschiedlichen zahlensysteme -\ mit $ und & zumindest im interpreter weglassen -\ schon erledigt! -\ 11may93jaw -\ name> 0= nicht vorhanden 17may93jaw -\ nfa can be lfa or nfa! -\ find splited into find and (find) -\ (find) for later use 17may93jaw -\ search replaced by lookup because -\ it is a word of the string wordset -\ 20may93jaw -\ postpone added immediate 21may93jaw -\ to added immediate 07jun93jaw -\ cfa, header put "here lastcfa !" in -\ cfa, this is more logical -\ and noname: works wothout -\ extra "here lastcfa !" 08jun93jaw -\ (parse-white) thrown out -\ refill added outer trick -\ to show there is something -\ going on 09jun93jaw -\ leave ?leave somebody forgot UNLOOP!!! 09jun93jaw -\ leave ?leave unloop thrown out -\ unloop after loop is used 10jun93jaw - HEX \ labels for some code addresses @@ -514,8 +488,8 @@ hex \ ?stack 23feb93py : ?stack ( ?? -- ?? ) \ gforth - sp@ s0 @ > IF -4 throw THEN - fp@ f0 @ > IF -&45 throw THEN ; + sp@ s0 @ u> IF -4 throw THEN + fp@ f0 @ u> IF -&45 throw THEN ; \ ?stack should be code -- it touches an empty stack! \ interpret 10mar92py @@ -587,291 +561,6 @@ Defer interpreter-notfound ( c-addr coun : ] ( -- ) \ core right-bracket ['] compiler IS parser state on ; -here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs -AConstant locals-list \ acts like a variable that contains - \ a linear list of locals names - - -variable dead-code \ true if normal code at "here" would be dead -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 ( -- ) \ gforth - \ declares the current point of execution as unreachable - dead-code on - 0 backedge-locals ! ; immediate - -: ASSUME-LIVE ( orig -- orig ) \ gforth - \ used immediatly 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 - -\ Control Flow Stack -\ orig, etc. have the following structure: -\ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS ) -\ address (of the branch or the instruction to be branched to) (second) -\ locals-list (valid at address) (third) - -\ types -0 constant defstart -1 constant live-orig -2 constant dead-orig -3 constant dest \ the loopback branch is always assumed live -4 constant do-dest -5 constant scopestart - -: def? ( n -- ) - defstart <> abort" unstructured " ; - -: orig? ( n -- ) - dup live-orig <> swap dead-orig <> and abort" expected orig " ; - -: dest? ( n -- ) - dest <> abort" expected dest " ; - -: do-dest? ( n -- ) - do-dest <> abort" expected do-dest " ; - -: scope? ( n -- ) - scopestart <> abort" expected scope " ; - -: non-orig? ( n -- ) - dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ; - -: cs-item? ( n -- ) - live-orig scopestart 1+ within 0= abort" expected control flow stack item" ; - -3 constant cs-item-size - -: CS-PICK ( ... u -- ... destu ) \ tools-ext - 1+ cs-item-size * 1- >r - r@ pick r@ pick r@ pick - rdrop - dup non-orig? ; - -: CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext - 1+ cs-item-size * 1- >r - r@ roll r@ roll r@ roll - rdrop - dup cs-item? ; - -: cs-push-part ( -- list addr ) - locals-list @ here ; - -: cs-push-orig ( -- orig ) - cs-push-part dead-code @ - if - dead-orig - else - live-orig - then ; - -\ Structural Conditionals 12dec92py - -: ?struc ( flag -- ) abort" unstructured " ; -: sys? ( sys -- ) dup 0= ?struc ; -: >mark ( -- orig ) - cs-push-orig 0 , ; -: >resolve ( addr -- ) here over - swap ! ; -: mark POSTPONE unreachable ; immediate restrict - -: IF ( compilation -- orig ; run-time f -- ) \ core - POSTPONE ?branch >mark ; immediate restrict - -: ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if -\G This is the preferred alternative to the idiom "?DUP IF", since it can be -\G better handled by tools like stack checkers. Besides, it's faster. - POSTPONE ?dup-?branch >mark ; immediate restrict - -: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if - POSTPONE ?dup-0=-?branch >mark ; immediate restrict - -Defer then-like ( orig -- addr ) -: cs>addr ( orig/dest -- addr ) drop nip ; -' cs>addr IS then-like - -: THEN ( compilation orig -- ; run-time -- ) \ core - dup orig? then-like >resolve ; immediate restrict - -' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth -immediate restrict -\ Same as "THEN". This is what you use if your program will be seen by -\ people who have not been brought up with Forth (or who have been -\ brought up with fig-Forth). - -: ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core - POSTPONE ahead - 1 cs-roll - POSTPONE then ; immediate restrict - -Defer begin-like ( -- ) -' noop IS begin-like - -: BEGIN ( compilation -- dest ; run-time -- ) \ core - begin-like cs-push-part dest ; immediate restrict - -Defer again-like ( dest -- addr ) -' nip IS again-like - -: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext - dest? again-like POSTPONE branch leave ( orig -- ) - \ push on leave-stack - leave-sp @ - dup [ leave-stack 60 cells + ] Aliteral - >= abort" leave-stack full" - tuck ! cell+ - tuck ! cell+ - tuck ! cell+ - leave-sp ! ; - -: leave> ( -- orig ) - \ pop from leave-stack - leave-sp @ - dup leave-stack <= IF - drop 0 0 0 EXIT THEN - cell - dup @ swap - cell - dup @ swap - cell - dup @ swap - leave-sp ! ; - -: DONE ( compilation orig -- ; run-time -- ) \ gforth - \ !! the original done had ( addr -- ) - drop >r drop - begin - leave> - over r@ u>= - while - POSTPONE then - repeat - >leave rdrop ; immediate restrict - -: LEAVE ( compilation -- ; run-time loop-sys -- ) \ core - POSTPONE ahead - >leave ; immediate restrict - -: ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth question-leave - POSTPONE 0= POSTPONE if - >leave ; immediate restrict - -: DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core - POSTPONE (do) - POSTPONE begin drop do-dest - ( 0 0 0 >leave ) ; immediate restrict - -: ?do-like ( -- do-sys ) - ( 0 0 0 >leave ) - >mark >leave - POSTPONE begin drop do-dest ; - -: ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do - POSTPONE (?do) ?do-like ; immediate restrict - -: +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do - POSTPONE (+do) ?do-like ; immediate restrict - -: U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do - POSTPONE (u+do) ?do-like ; immediate restrict - -: -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do - POSTPONE (-do) ?do-like ; immediate restrict - -: U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do - POSTPONE (u-do) ?do-like ; immediate restrict - -: FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth - POSTPONE (for) - POSTPONE begin drop do-dest - ( 0 0 0 >leave ) ; immediate restrict - -\ LOOP etc. are just like UNTIL - -: loop-like ( do-sys xt1 xt2 -- ) - >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? - until-like POSTPONE done POSTPONE unloop ; - -: LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core - ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict - -: +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop - ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict - -\ !! should the compiler warn about +DO..-LOOP? -: -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop - ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict - -\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" -\ will iterate as often as "high low ?DO inc S+LOOP". For positive -\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for -\ negative increments. -: S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop - ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict - -: NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth - ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict - -\ Structural Conditionals 12dec92py - -Defer exit-like ( -- ) -' noop IS exit-like - -: EXIT ( compilation -- ; run-time nest-sys -- ) \ core - exit-like - POSTPONE ;s - POSTPONE unreachable ; immediate restrict - -: ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth - POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict - \ Strings 22feb93py : ," ( "string"<"> -- ) [char] " parse @@ -883,14 +572,33 @@ Defer exit-like ( -- ) : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string postpone (S") here over char+ allot place align ; immediate restrict -: ( ( compilation 'ccc' -- ; run-time -- ) \ core,file paren +: plain-( ( 'ccc' -- ; ) + [char] ) parse 2drop ; + +: file-( ( 'ccc' -- ; ) BEGIN - >in @ [char] ) parse nip >in @ rot - = + >in @ + [char] ) parse nip + >in @ rot - = \ is there no delimter? WHILE - loadfile @ IF - refill 0= abort" missing ')' in paren comment" + refill 0= + IF + warnings @ + IF + ." warning: ')' missing" cr + THEN + EXIT THEN - REPEAT ; immediate + REPEAT ; + +: ( ( compilation 'ccc' -- ; run-time -- ) \ core,file paren + loadfile @ + IF + file-( + ELSE + plain-( + THEN ; immediate + : \ ( -- ) \ core-ext backslash blk @ IF @@ -1164,7 +872,7 @@ end-struct interpret/compile-struct (cfa>int) ; : name>comp ( nt -- w xt ) \ gforth - \G @var{w xt} is the compilation token wor the word @var{nt}. + \G @var{w xt} is the compilation token for the word @var{nt}. (name>x) >r dup interpret/compile? if interpret/compile-comp @ @@ -1359,9 +1067,9 @@ Defer key ( -- c ) \ core 1 loadline +! swap #tib ! 0 >in ! ; -: Query ( -- ) \ core-ext +: query ( -- ) \ core-ext \G obsolescent - loadfile off blk off refill drop ; + tib /line accept #tib ! 0 >in ! ; \ File specifiers 11jun93jaw @@ -1381,16 +1089,12 @@ Defer key ( -- c ) \ core : bin ( fam1 -- fam2 ) \ file 1 or ; -create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos - \ or not unix environments if - \ bin is not selected - : write-line ( c-addr u fileid -- ior ) \ file dup >r write-file ?dup IF r> drop EXIT THEN - nl$ count r> write-file ; + #lf r> emit-file ; \ include-file 07apr93py @@ -1615,7 +1319,9 @@ create image-included-files 1 , A, ( po Defer 'quit Defer .status : prompt state @ IF ." compiled" EXIT THEN ." ok" ; -: (quit) BEGIN .status cr query interpret prompt AGAIN ; +: (Query) ( -- ) + loadfile off blk off refill drop ; +: (quit) BEGIN .status cr (query) interpret prompt AGAIN ; ' (quit) IS 'quit \ DOERROR (DOERROR) 13jun93jaw @@ -1640,8 +1346,8 @@ max-errors 6 * cells allot : typewhite ( addr u -- ) \ gforth \ like type, but white space is printed instead of the characters bounds ?do - i c@ 9 = if \ check for tab - 9 + i c@ #tab = if \ check for tab + #tab else bl then @@ -1811,9 +1517,13 @@ Defer 'cold ' noop IS 'cold ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; : boot ( path **argv argc -- ) - argc ! argv ! save-mem pathstring 2! main-task up! - sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off - rp@ r0 ! fp@ f0 ! ['] cold catch DoError bye ; + argc ! argv ! pathstring 2! main-task up! + sp@ s0 ! + lp@ forthstart 7 cells + @ - dup >tib ! tibstack ! #tib off >in off + rp@ r0 ! + fp@ f0 ! + ['] cold catch DoError + bye ; : bye ( -- ) \ tools-ext script? 0= IF cr THEN 0 (bye) ;