--- gforth/Attic/kernal.fs 1994/05/07 14:55:58 1.5 +++ gforth/Attic/kernal.fs 1994/07/13 19:21:03 1.11 @@ -57,6 +57,17 @@ DOES> ( n -- ) + c@ ; [ cell 1- ] Literal + [ -1 cells ] Literal and ; : align ( -- ) here dup aligned swap ?DO bl c, LOOP ; +: faligned ( addr -- f-addr ) + [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; + +: falign ( -- ) + here dup faligned swap + ?DO + bl c, + LOOP ; + + + : A! ( addr1 addr2 -- ) dup relon ! ; : A, ( addr -- ) here cell allot A! ; @@ -68,13 +79,13 @@ DOES> ( n -- ) + c@ ; \ name> found 17dec92py : (name>) ( nfa -- cfa ) count $1F and + aligned ; -: name> ( nfa -- cfa ) +: 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 -\ -1 r@ $40 and IF 1- THEN - -1 r> $20 and IF negate THEN ; + -1 r@ $40 and IF 1- THEN + r> $20 and IF negate THEN ; \ (find) 17dec92py @@ -131,12 +142,13 @@ Defer source dup count chars bounds ?DO I c@ toupper I c! 1 chars +LOOP ; : (name) ( -- addr ) bl word ; +: (cname) ( -- addr ) bl word capitalize ; \ Literal 17dec92py -: Literal ( n -- ) state @ 0= ?EXIT postpone lit , ; +: Literal ( n -- ) state @ IF postpone lit , THEN ; immediate -: ALiteral ( n -- ) state @ 0= ?EXIT postpone lit A, ; +: ALiteral ( n -- ) state @ IF postpone lit A, THEN ; immediate : char ( 'char' -- n ) bl word char+ c@ ; @@ -154,7 +166,10 @@ Defer source \ digit? 17dec92py : digit? ( char -- digit true/ false ) - base @ $100 = ?dup ?EXIT + base @ $100 = + IF + true EXIT + THEN toupper [char] 0 - dup 9 u> IF [ 'A '9 1 + - ] literal - dup 9 u<= IF @@ -240,7 +255,6 @@ hex \ catch throw 23feb93py \ bounce 08jun93jaw -\ !! what about the other stacks (FP, locals) anton \ !! allow the user to add rollback actions anton \ !! use a separate exception stack? anton @@ -254,15 +268,18 @@ hex handler @ >r rp@ handler ! execute - r> handler ! rdrop rdrop 0 ; + r> handler ! rdrop rdrop rdrop 0 ; + : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) - ?DUP IF - handler @ rp! - r> handler ! - r> lp! - r> fp! - r> swap >r sp! r> - THEN ; + ?DUP IF + [ here 4 cells ! ] + handler @ rp! + r> handler ! + r> lp! + r> fp! + r> swap >r sp! r> + THEN ; + \ Bouncing is very fine, \ programming without wasting time... jaw : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) @@ -309,90 +326,366 @@ Defer notfound : [ ['] interpreter IS parser state off ; immediate : ] ['] compiler IS parser state on ; +\ locals stuff needed for control structures + +: compile-lp+! ( n -- ) + dup negate locals-size +! + 0 over = if + else -4 over = if postpone -4lp+! + else 8 over = if postpone 8lp+! + else 16 over = if postpone 16lp+! + else postpone lp+!# dup , + then then then then drop ; + +: adjust-locals-size ( n -- ) + \ sets locals-size to n and generates an appropriate lp+! + locals-size @ swap - compile-lp+! ; + + +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 + +: unreachable ( -- ) +\ declares the current point of execution as unreachable + dead-code on ; + +\ locals list operations + +: common-list ( list1 list2 -- list3 ) +\ list1 and list2 are lists, where the heads are at higher addresses than +\ the tail. list3 is the largest sublist of both lists. + begin + 2dup u<> + while + 2dup u> + if + swap + then + @ + repeat + drop ; + +: sub-list? ( list1 list2 -- f ) +\ true iff list1 is a sublist of list2 + begin + 2dup u< + while + @ + repeat + = ; + +: list-size ( list -- u ) +\ size of the locals frame represented by list + 0 ( list n ) + begin + over 0<> + while + over + name> >body @ max + swap @ swap ( get next ) + repeat + faligned nip ; + +: set-locals-size-list ( list -- ) + dup locals-list ! + list-size locals-size ! ; + +: check-begin ( list -- ) +\ warn if list is not a sublist of locals-list + locals-list @ sub-list? 0= if + \ !! print current position + ." compiler was overly optimistic about locals at a BEGIN" cr + \ !! print assumption and reality + then ; + +\ 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 ) + 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 ) + 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 ( -- sys ) here 0 , ; -: >resolve ( sys -- ) here over - swap ! ; -: mark ( -- orig ) + cs-push-orig 0 , ; +: >resolve ( addr -- ) here over - swap ! ; +: mark ; immediate restrict -: IF postpone ?branch >mark ; immediate restrict +: AHEAD ( -- orig ) + POSTPONE branch >mark unreachable ; immediate restrict + +: IF ( -- orig ) + POSTPONE ?branch >mark ; immediate restrict + : ?DUP-IF \ general \ This is the preferred alternative to the idiom "?DUP IF", since it can be \ better handled by tools like stack checkers - postpone ?dup postpone IF ; immediate restrict + POSTPONE ?dup POSTPONE if ; immediate restrict : ?DUP-NOT-IF \ general - postpone ?dup postpone 0= postpone if ; immediate restrict -: THEN sys? dup @ ?struc >resolve ; immediate restrict + POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict + +: THEN ( orig -- ) + dup orig? + dead-code @ + if + dead-orig = + if + >resolve drop + else + >resolve set-locals-size-list dead-code off + then + else + dead-orig = + if + >resolve drop + else \ both live + over list-size adjust-locals-size + >resolve + locals-list @ common-list dup list-size adjust-locals-size + locals-list ! + then + then ; immediate restrict + ' THEN alias ENDIF immediate restrict \ general \ 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 sys? postpone AHEAD swap postpone THEN ; - immediate restrict - -: BEGIN here ; immediate restrict -: WHILE sys? postpone IF swap ; immediate restrict -: AGAIN sys? postpone branch if + dup cs-item? + 2 pick + else + 0 + then + set-locals-size-list + then + cs-push-part dest + dead-code off ; immediate restrict + +\ AGAIN (the current control flow joins another, earlier one): +\ If the dest-locals-list is not a subset of the current locals-list, +\ issue a warning (see below). The following code is generated: +\ lp+!# (current-local-size - dest-locals-size) +\ branch +: AGAIN ( dest -- ) + dest? + over list-size adjust-locals-size + POSTPONE branch + (current-local-size - dest-locals-size) +: until-like ( list addr xt1 xt2 -- ) + \ list and addr are a fragment of a cs-item + \ xt1 is the conditional branch without lp adjustment, xt2 is with + >r >r + locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment ) + r> drop r> compile, + swap compile, drop + then ( list ) + check-begin ; + +: UNTIL ( dest -- ) + dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict + +: WHILE ( dest -- orig dest ) + POSTPONE if + 1 cs-roll ; immediate restrict + +: REPEAT ( orig dest -- ) + POSTPONE again + POSTPONE then ; immediate restrict + + +\ counted loops + +\ leave poses a little problem here +\ we have to store more than just the address of the branch, so the +\ traditional linked list approach is no longer viable. +\ This is solved by storing the information about the leavings in a +\ special stack. + +\ !! remove the fixed size limit. 'Tis not hard. +20 constant leave-stack-size +create leave-stack 60 cells allot +Avariable leave-sp leave-stack 3 cells + leave-sp ! + +: clear-leave-stack ( -- ) + leave-stack leave-sp ! ; + +\ : leave-empty? ( -- f ) +\ leave-sp @ leave-stack = ; + +: >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 ( orig -- ) drop >r drop + \ !! the original done had ( addr -- ) + begin + leave> + over r@ u>= + while + POSTPONE then + repeat + >leave rdrop ; immediate restrict + +: LEAVE ( -- ) + POSTPONE ahead + >leave ; immediate restrict + +: ?LEAVE ( -- ) + POSTPONE 0= POSTPONE if + >leave ; immediate restrict + +: DO ( -- do-sys ) + POSTPONE (do) + POSTPONE begin drop do-dest + ( 0 0 0 >leave ) ; immediate restrict + +: ?DO ( -- do-sys ) + ( 0 0 0 >leave ) + POSTPONE (?do) + >mark >leave + POSTPONE begin drop do-dest ; immediate restrict + +: FOR ( -- do-sys ) + 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 ( do-sys -- ) + ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict + +: +LOOP ( do-sys -- ) + ['] (+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 ( do-sys -- ) + ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict -variable locals-size \ this is the current size of the locals stack - \ frame of the current word - -: compile-lp+!# ( n -- ) - ?DUP IF - dup negate locals-size +! - postpone lp+!# , - THEN ; - -\ : EXIT ( -- ) -\ locals-size @ compile-lp+!# POSTPONE ;s ; immediate restrict -\ : ?EXIT ( -- ) -\ postpone IF postpone EXIT postpone THEN ; immediate restrict - -Variable leavings - -: (leave) here leavings @ , leavings ! ; -: LEAVE postpone branch (leave) ; immediate restrict -: ?LEAVE postpone 0= postpone ?branch (leave) ; - immediate restrict -: DONE ( addr -- ) - leavings @ - BEGIN - 2dup u<= - WHILE - dup @ swap >resolve - REPEAT - leavings ! drop ; immediate restrict +: NEXT ( do-sys -- ) + ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict \ Structural Conditionals 12dec92py -: DO postpone (do) here ; immediate restrict - -: ?DO postpone (?do) (leave) here ; - immediate restrict -: FOR postpone (for) here ; immediate restrict - -: loop] dup &-19 and throw ( is name too long? ) + 1+ chars allot align ; : input-stream-header ( "name" -- ) \ !! this is f83-implementation-dependent align here last ! -1 A, @@ -459,7 +756,7 @@ create nextname-buffer 32 chars allot \ the next name is given in the string : nextname ( c-addr u -- ) \ general - dup 31 u> -19 and throw ( is name too long? ) + dup $1F u> &-19 and throw ( is name too long? ) nextname-buffer c! ( c-addr ) nextname-buffer count move ['] nextname-header IS header ; @@ -482,7 +779,7 @@ create nextname-buffer 32 chars allot : name>string ( nfa -- addr count ) cell+ count $1F and ; -Create ??? ," ???" +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 @@ -564,13 +861,13 @@ Create ??? ," ???" defer :-hook ( sys1 -- sys2 ) defer ;-hook ( sys2 -- sys1 ) -: EXIT ( -- ) postpone ;s ; immediate - -: : ( -- colon-sys ) Header [ :docol ] Literal cfa, 0 ] :-hook ; +: : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ; : ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict -: :noname ( -- xt colon-sys ) here [ :docol ] Literal cfa, 0 ] :-hook ; +: :noname ( -- xt colon-sys ) + 0 last ! + here [ :docol ] Literal cfa, 0 ] :-hook ; \ Search list handling 23feb93py @@ -592,27 +889,35 @@ AVariable current \ word list structure: \ struct -\ 1 cells: field find-method \ xt: ( c_addr u w1 -- name-id ) w1 is a method-\ specific wordlist-id (not the same as wid) +\ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) \ 1 cells: field reveal-method \ xt: ( -- ) +\ 1 cells: field rehash-method \ xt: ( wid -- ) \ \ !! what else \ end-struct wordlist-map-struct \ struct \ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation \ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct -\ 1 cells: field ???? -\ 1 cells: field ???? +\ 1 cells: field wordlist-link \ link field to other wordlists +\ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) \ end-struct wordlist-struct +: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; +: f83casefind ( addr len wordlist -- nfa / false ) @ (f83casefind) ; \ Search list table: find reveal -Create f83search ' (f83find) A, ' (reveal) A, +Create f83search ' f83casefind A, ' (reveal) A, ' drop A, + +: caps-name ['] (cname) IS name ['] f83find f83search ! ; +: case-name ['] (name) IS name ['] f83casefind f83search ! ; +: case-sensitive ['] (name) IS name ['] f83find f83search ! ; + Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, AVariable search G forth-wordlist search T ! G forth-wordlist current T ! : (search-wordlist) ( addr count wid -- nfa / false ) - dup @ swap cell+ @ @ execute ; + dup ( @ swap ) cell+ @ @ execute ; : search-wordlist ( addr count wid -- 0 / xt +-1 ) (search-wordlist) dup IF found THEN ; @@ -642,6 +947,8 @@ Variable warnings G -1 warnings T ! then current @ cell+ @ cell+ @ execute ; +: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; + : ' ( "name" -- addr ) name find 0= no.extensions ; : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate \ Input 13feb93py @@ -698,14 +1005,14 @@ Create crtlkeys DEFER type \ defer type for a output buffer or fast \ screen write -: (type) ( addr len -- ) - bounds ?DO I c@ emit LOOP ; +\ : (type) ( addr len -- ) +\ bounds ?DO I c@ emit LOOP ; ' (TYPE) IS Type -\ DEFER Emit +DEFER Emit -\ ' (Emit) IS Emit +' (Emit) IS Emit \ : form ( -- rows cols ) &24 &80 ; \ form should be implemented using TERMCAPS or CURSES @@ -723,9 +1030,9 @@ DEFER type \ defer type for a outpu accept true THEN 1 loadline +! - swap #tib ! >in off ; + swap #tib ! 0 >in ! ; -: Query ( -- ) loadfile off refill drop ; +: Query ( -- ) 0 loadfile ! refill drop ; \ File specifiers 11jun93jaw @@ -766,7 +1073,13 @@ create nl$ 1 c, A c, 0 c, \ gnu includes r> loadfile ! r> loadline ! r> linestart ! ; : included ( i*x addr u -- j*x ) - r/o open-file throw include-file ; + loadfilename 2@ >r >r + dup allocate throw over loadfilename 2! + over loadfilename 2@ move + r/o open-file throw include-file + \ don't free filenames; they don't take much space + \ and are used for debugging + r> r> loadfilename 2! ; \ HEX DECIMAL 2may93jaw @@ -779,13 +1092,15 @@ create nl$ 1 c, A c, 0 c, \ gnu includes \ INCLUDE 9may93jaw -: include - bl word count included ; +: include ( "file" -- ) + bl word count included ; \ RECURSE 17may93jaw -: recurse last @ cell+ name> a, ; immediate restrict -\ !! does not work with anonymous words; use lastxt compile, +: recurse ( -- ) + lastxt compile, ; immediate restrict +: recursive ( -- ) + reveal ; immediate \ */MOD */ 17may93jaw @@ -823,35 +1138,47 @@ Defer .status \ DOERROR (DOERROR) 13jun93jaw +: dec. ( n -- ) + \ print value in decimal representation + base @ decimal swap . base ! ; + +: typewhite ( addr u -- ) + \ like type, but white space is printed instead of the characters + 0 ?do + dup i + c@ 9 = if \ check for tab + 9 + else + bl + then + emit + loop + drop ; + DEFER DOERROR : (DoError) ( throw-code -- ) - LoadFile @ - IF - ." Error in line: " Loadline @ . cr - THEN - cr source type cr - source drop >in @ -trailing - here c@ 1F min dup >r - 1- 0 max nip - dup spaces - IF - ." ^" - THEN - r> 0 ?DO - ." -" - LOOP - ." ^" - dup -2 = - IF - "error @ ?dup - IF - cr count type - THEN - drop - ELSE - .error - THEN - normal-dp dpp ! ; + LoadFile @ + IF + cr loadfilename 2@ type ." :" Loadline @ dec. + THEN + cr source type cr + source drop >in @ -trailing ( throw-code line-start index2 ) + here c@ 1F min dup >r - 0 max ( throw-code line-start index1 ) + typewhite + r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 + ." ^" + loop + dup -2 = + IF + "error @ ?dup + IF + cr count type + THEN + drop + ELSE + .error + THEN + normal-dp dpp ! ; ' (DoError) IS DoError @@ -886,11 +1213,21 @@ Variable argc : script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ; : cold ( -- ) - argc @ 1 > - IF script? - IF 1 arg ['] included ELSE get-args ['] interpret THEN - catch ?dup IF dup >r DoError cr r> (bye) THEN THEN - ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ; + argc @ 1 > + IF script? + IF + 1 arg ['] included + ELSE + get-args ['] interpret + THEN + catch ?dup + IF + dup >r DoError cr r> (bye) + THEN + THEN + cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation" + cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" + cr quit ; : boot ( **env **argv argc -- ) argc ! argv ! env ! main-task up!