Diff for /gforth/Attic/kernel.fs between versions 1.3 and 1.12

version 1.3, 1996/09/24 19:15:03 version 1.12, 1997/02/01 14:59:31
Line 20 Line 20
   
 \ Idea and implementation: Bernd Paysan (py)  \ 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  HEX
   
 \ labels for some code addresses  \ labels for some code addresses
Line 179  $20 constant restrict-mask Line 153  $20 constant restrict-mask
     over + swap ;      over + swap ;
   
 : save-mem      ( addr1 u -- addr2 u ) \ gforth  : save-mem      ( addr1 u -- addr2 u ) \ gforth
     \ copy a memory block into a newly allocated region in the heap      \g copy a memory block into a newly allocated region in the heap
     swap >r      swap >r
     dup allocate throw      dup allocate throw
     swap 2dup r> -rot move ;      swap 2dup r> -rot move ;
Line 276  Defer source ( -- addr count ) \ core Line 250  Defer source ( -- addr count ) \ core
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
   
 \ not the most efficient implementation of POSTPONE, but simple  : postpone, ( w xt -- )
 : POSTPONE ( -- ) \ core      \g Compiles the compilation semantics represented by @var{w xt}.
     COMP' swap POSTPONE aliteral compile, ; immediate restrict      dup ['] execute =
       if
           drop compile,
       else
           dup ['] compile, =
           if
               drop POSTPONE (compile) compile,
           else
               swap POSTPONE aliteral compile,
           then
       then ;
   
   : POSTPONE ( "name" -- ) \ core
       \g Compiles the compilation semantics of @var{name}.
       COMP' postpone, ; immediate restrict
   
 : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth  : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
     Create immediate swap A, A,      Create immediate swap A, A,
Line 500  hex Line 488  hex
 \ ?stack                                               23feb93py  \ ?stack                                               23feb93py
   
 : ?stack ( ?? -- ?? ) \ gforth  : ?stack ( ?? -- ?? ) \ gforth
     sp@ s0 @ > IF    -4 throw  THEN      sp@ s0 @ u> IF    -4 throw  THEN
     fp@ f0 @ > IF  -&45 throw  THEN  ;      fp@ f0 @ u> IF  -&45 throw  THEN  ;
 \ ?stack should be code -- it touches an empty stack!  \ ?stack should be code -- it touches an empty stack!
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
Line 549  Defer interpreter-notfound ( c-addr coun Line 537  Defer interpreter-notfound ( c-addr coun
   
 : compiler ( c-addr u -- )  : compiler ( c-addr u -- )
     2dup find-name dup      2dup find-name dup
     if ( c-addr u nfa )      if ( c-addr u nt )
         nip nip name>comp execute          nip nip name>comp execute
     else      else
         drop          drop
Line 573  Defer interpreter-notfound ( c-addr coun Line 561  Defer interpreter-notfound ( c-addr coun
 : ] ( -- ) \ core       right-bracket  : ] ( -- ) \ core       right-bracket
     ['] compiler     IS parser state on  ;      ['] 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 ! ;  
 : <resolve    ( addr -- )        here - , ;  
   
 : BUT  
     1 cs-roll ;                      immediate restrict  
 : YET  
     0 cs-pick ;                       immediate restrict  
   
 \ Structural Conditionals                              12dec92py  
   
 : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext  
     POSTPONE branch  >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  <resolve ; immediate restrict  
   
 Defer until-like  
 : until, ( list addr xt1 xt2 -- )  drop compile, <resolve drop ;  
 ' until, IS until-like  
   
 : UNTIL ( compilation dest -- ; run-time f -- ) \ core  
     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict  
   
 : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core  
     POSTPONE if  
     1 cs-roll ; immediate restrict  
   
 : REPEAT ( compilation orig dest -- ; run-time -- ) \ core  
     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 ( 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  \ Strings                                              22feb93py
   
 : ," ( "string"<"> -- ) [char] " parse  : ," ( "string"<"> -- ) [char] " parse
Line 869  Defer exit-like ( -- ) Line 572  Defer exit-like ( -- )
 : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string  : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
     postpone (S") here over char+ allot  place align ;      postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               immediate restrict
 : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  : plain-( ( 'ccc<close-paren>' -- ; )
       [char] ) parse 2drop ;
   
   : file-( ( 'ccc<close-paren>' -- ; )
     BEGIN      BEGIN
         >in @ [char] ) parse nip >in @ rot - =          >in @
           [char] ) parse nip
           >in @ rot - = \ is there no delimter?
     WHILE      WHILE
         loadfile @ IF          refill 0=
             refill 0= abort" missing ')' in paren comment"          IF
               warnings @
               IF
                   ." warning: ')' missing" cr
               THEN
               EXIT
         THEN          THEN
     REPEAT ;                       immediate      REPEAT ;
   
   : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren
       loadfile @
       IF
           file-(
       ELSE
           plain-(
       THEN ; immediate
   
 : \ ( -- ) \ core-ext backslash  : \ ( -- ) \ core-ext backslash
     blk @      blk @
     IF      IF
Line 981  create nextname-buffer 32 chars allot Line 703  create nextname-buffer 32 chars allot
     alias-mask lastflags creset      alias-mask lastflags creset
     dup A, lastcfa ! ;      dup A, lastcfa ! ;
   
 : name>string ( nfa -- addr count ) \ gforth    name-to-string  : name>string ( nt -- addr count ) \ gforth     name-to-string
  cell+ count $1F and ;      \g @var{addr count} is the name of the word represented by @var{nt}.
       cell+ count $1F and ;
   
 Create ???  0 , 3 c, char ? c, char ? c, char ? c,  Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 : >name ( cfa -- nfa ) \ gforth to-name  : >name ( cfa -- nt ) \ gforth  to-name
  $21 cell do   $21 cell do
    dup i - count $9F and + cfaligned over alias-mask + = if     dup i - count $9F and + cfaligned over alias-mask + = if
      i - cell - unloop exit       i - cell - unloop exit
Line 1074  AVariable current ( -- addr ) \ gforth Line 797  AVariable current ( -- addr ) \ gforth
   
 : last?   ( -- false / nfa nfa )  : last?   ( -- false / nfa nfa )
     last @ ?dup ;      last @ ?dup ;
 : (reveal) ( nfa wid -- )  : (reveal) ( nt wid -- )
     ( wid>wordlist-id ) dup >r      ( wid>wordlist-id ) dup >r
     @ over ( name>link ) !       @ over ( name>link ) ! 
     r> ! ;      r> ! ;
Line 1084  AVariable current ( -- addr ) \ gforth Line 807  AVariable current ( -- addr ) \ gforth
 \ word list structure:  \ word list structure:
   
 struct  struct
   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )    1 cells: field find-method   \ xt: ( c_addr u wid -- nt )
   1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field    1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
   1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field rehash-method \ xt: ( wid -- )
 \   \ !! what else  \   \ !! what else
 end-struct wordlist-map-struct  end-struct wordlist-map-struct
Line 1097  struct Line 820  struct
   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)    1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
 end-struct wordlist-struct  end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nfa / false )  : f83find      ( addr len wordlist -- nt / false )
     ( wid>wordlist-id ) @ (f83find) ;      ( wid>wordlist-id ) @ (f83find) ;
   
 \ Search list table: find reveal  \ Search list table: find reveal
Line 1134  end-struct interpret/compile-struct Line 857  end-struct interpret/compile-struct
         (cfa>int)          (cfa>int)
     then ;      then ;
   
 : name>int ( nfa -- xt ) \ gforth  : name>int ( nt -- xt ) \ gforth
       \G @var{xt} represents the interpretation semantics of the word
       \G @var{nt}. Produces @code{' compile-only-error} if
       \G @var{nt} is compile-only.
     (name>x) (x>int) ;      (name>x) (x>int) ;
   
 : name?int ( nfa -- xt ) \ gforth  : name?int ( nt -- xt ) \ gforth
     \G like name>int, but throws an error if compile-only      \G Like name>int, but throws an error if compile-only.
     (name>x) restrict-mask and      (name>x) restrict-mask and
     if      if
         compile-only-error \ does not return          compile-only-error \ does not return
     then      then
     (cfa>int) ;      (cfa>int) ;
   
 : name>comp ( nfa -- w xt ) \ gforth  : name>comp ( nt -- w xt ) \ gforth
     \G get compilation semantics of name      \G @var{w xt} is the compilation token for the word @var{nt}.
     (name>x) >r dup interpret/compile?      (name>x) >r dup interpret/compile?
     if      if
         interpret/compile-comp @          interpret/compile-comp @
Line 1157  end-struct interpret/compile-struct Line 883  end-struct interpret/compile-struct
         ['] compile,          ['] compile,
     then ;      then ;
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nt / false )
     dup wordlist-map @ find-method perform ;      dup wordlist-map @ find-method perform ;
   
 : flag-sign ( f -- 1|-1 )  : flag-sign ( f -- 1|-1 )
Line 1174  end-struct interpret/compile-struct Line 900  end-struct interpret/compile-struct
         (name>intn)          (name>intn)
     then ;      then ;
   
 : find-name ( c-addr u -- nfa/0 )  : find-name ( c-addr u -- nt/0 ) \ gforth
       \g Find the name @var{c-addr u} in the current search
       \g order. Return its nt, if found, otherwise 0.
     lookup @ (search-wordlist) ;      lookup @ (search-wordlist) ;
   
 : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
     find-name dup      find-name dup
     if ( nfa )      if ( nt )
         state @          state @
         if          if
             name>comp ['] execute = flag-sign              name>comp ['] execute = flag-sign
Line 1194  end-struct interpret/compile-struct Line 922  end-struct interpret/compile-struct
         rot drop          rot drop
     then ;      then ;
   
 : (') ( "name" -- nfa ) \ gforth  : (') ( "name" -- nt ) \ gforth
     name find-name dup 0=      name find-name dup 0=
     IF      IF
         drop -&13 bounce          drop -&13 bounce
     THEN  ;      THEN  ;
   
 : [(')]  ( compilation "name" -- ; run-time -- nfa ) \ gforth   bracket-paren-tick  : [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth    bracket-paren-tick
     (') postpone ALiteral ; immediate restrict      (') postpone ALiteral ; immediate restrict
   
 : '    ( "name" -- xt ) \ core  tick  : '    ( "name" -- xt ) \ core  tick
       \g @var{xt} represents @var{name}'s interpretation
       \g semantics. Performs @code{-14 throw} if the word has no
       \g interpretation semantics.
     (') name?int ;      (') name?int ;
 : [']  ( compilation "name" -- ; run-time -- xt ) \ core        bracket-tick  : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core      bracket-tick
       \g @var{xt} represents @var{name}'s interpretation
       \g semantics. Performs @code{-14 throw} if the word has no
       \g interpretation semantics.
     ' postpone ALiteral ; immediate restrict      ' postpone ALiteral ; immediate restrict
   
 : COMP'    ( "name" -- w xt ) \ gforth  c-tick  : COMP'    ( "name" -- w xt ) \ gforth  c-tick
       \g @var{w xt} represents @var{name}'s compilation semantics.
     (') name>comp ;      (') name>comp ;
 : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth        bracket-comp-tick  : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth        bracket-comp-tick
       \g @var{w xt} represents @var{name}'s compilation semantics.
     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict      COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
   
 \ reveal words  \ reveal words
Line 1236  G -1 warnings T ! Line 972  G -1 warnings T !
     if \ the last word has a header      if \ the last word has a header
         dup ( name>link ) @ 1 and          dup ( name>link ) @ 1 and
         if \ it is still hidden          if \ it is still hidden
             dup ( name>link ) @ 1 xor           ( nfa wid )              dup ( name>link ) @ 1 xor           ( nt wid )
             2dup >r name>string r> check-shadow ( nfa wid )              2dup >r name>string r> check-shadow ( nt wid )
             dup wordlist-map @ reveal-method perform              dup wordlist-map @ reveal-method perform
         then          then
     then ;      then ;
Line 1331  Defer key ( -- c ) \ core Line 1067  Defer key ( -- c ) \ core
   1 loadline +!    1 loadline +!
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- ) \ core-ext  : query   ( -- ) \ core-ext
     \G obsolescent      \G obsolescent
     loadfile off  blk off  refill drop ;      tib /line accept #tib ! 0 >in ! ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1353  Defer key ( -- c ) \ core Line 1089  Defer key ( -- c ) \ core
 : bin ( fam1 -- fam2 ) \ file  : bin ( fam1 -- fam2 ) \ file
     1 or ;      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  : write-line ( c-addr u fileid -- ior ) \ file
     dup >r write-file      dup >r write-file
     ?dup IF      ?dup IF
         r> drop EXIT          r> drop EXIT
     THEN      THEN
     nl$ count r> write-file ;      #lf r> emit-file ;
   
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
Line 1587  create image-included-files  1 , A, ( po Line 1319  create image-included-files  1 , A, ( po
 Defer 'quit  Defer 'quit
 Defer .status  Defer .status
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : 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  ' (quit) IS 'quit
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
Line 1612  max-errors 6 * cells allot Line 1346  max-errors 6 * cells allot
 : typewhite ( addr u -- ) \ gforth  : typewhite ( addr u -- ) \ gforth
     \ like type, but white space is printed instead of the characters      \ like type, but white space is printed instead of the characters
     bounds ?do      bounds ?do
         i c@ 9 = if \ check for tab          i c@ #tab = if \ check for tab
             9              #tab
         else          else
             bl              bl
         then          then
Line 1701  Variable argc Line 1435  Variable argc
     \ addr1 u1 is a path string, addr2 u2 is an array of dir strings      \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
     align here >r      align here >r
     BEGIN      BEGIN
         over >r [char] : scan          over >r 0 scan
         over r> tuck - ( rest-str this-str )          over r> tuck - ( rest-str this-str )
         dup          dup
         IF          IF
Line 1783  Defer 'cold ' noop IS 'cold Line 1517  Defer 'cold ' noop IS 'cold
  ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;   ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
   
 : boot ( path **argv argc -- )  : boot ( path **argv argc -- )
   argc ! argv ! cstring>sstring pathstring 2!  main-task up!    argc ! argv ! pathstring 2!  main-task up!
   sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off    sp@ s0 !
   rp@ r0 !  fp@ f0 !  ['] cold catch DoError bye ;    lp@ forthstart 7 cells + @ - dup >tib ! tibstack ! #tib off >in off
     rp@ r0 !
     fp@ f0 !
     ['] cold catch DoError
     bye ;
   
 : bye ( -- ) \ tools-ext  : bye ( -- ) \ tools-ext
     script? 0= IF  cr  THEN  0 (bye) ;      script? 0= IF  cr  THEN  0 (bye) ;

Removed from v.1.3  
changed lines
  Added in v.1.12


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>