[BACK]Return to kernel.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/Attic/kernel.fs between versions 1.1 and 1.8

version 1.1, 1996/09/19 22:17:34 version 1.8, 1996/11/22 17:41:36
Line 51  HEX Line 51  HEX
 \ labels for some code addresses  \ labels for some code addresses
   
 : docon: ( -- addr )    \ gforth  : docon: ( -- addr )    \ gforth
     \ the code address of a @code{CONSTANT}      \G the code address of a @code{CONSTANT}
     ['] bl >code-address ;      ['] bl >code-address ;
   
 : docol: ( -- addr )    \ gforth  : docol: ( -- addr )    \ gforth
     \ the code address of a colon definition      \G the code address of a colon definition
     ['] docon: >code-address ;      ['] docon: >code-address ;
   
 : dovar: ( -- addr )    \ gforth  : dovar: ( -- addr )    \ gforth
     \ the code address of a @code{CREATE}d word      \G the code address of a @code{CREATE}d word
     ['] udp >code-address ;      ['] udp >code-address ;
   
 : douser: ( -- addr )   \ gforth  : douser: ( -- addr )   \ gforth
     \ the code address of a @code{USER} variable      \G the code address of a @code{USER} variable
     ['] s0 >code-address ;      ['] s0 >code-address ;
   
 : dodefer: ( -- addr )  \ gforth  : dodefer: ( -- addr )  \ gforth
     \ the code address of a @code{defer}ed word      \G the code address of a @code{defer}ed word
     ['] source >code-address ;      ['] source >code-address ;
   
 : dofield: ( -- addr )  \ gforth  : dofield: ( -- addr )  \ gforth
     \ the code address of a @code{field}      \G the code address of a @code{field}
     ['] reveal-method >code-address ;      ['] reveal-method >code-address ;
   
 NIL AConstant NIL \ gforth  NIL AConstant NIL \ gforth
Line 179  $20 constant restrict-mask Line 179  $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 276  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" -- )  : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
     Create immediate swap A, A,      Create immediate swap A, A,
 DOES>  DOES>
     abort" executed primary cfa of an interpret/compile: word" ;      abort" executed primary cfa of an interpret/compile: word" ;
Line 325  DOES> Line 339  DOES>
 \ number? number                                       23feb93py  \ number? number                                       23feb93py
   
 Create bases   10 ,   2 ,   A , 100 ,  Create bases   10 ,   2 ,   A , 100 ,
 \              16     2    10   Zeichen  \              16     2    10   character
 \ !! this saving and restoring base is an abomination! - anton  \ !! this saving and restoring base is an abomination! - anton
 : getbase ( addr u -- addr' u' )  : getbase ( addr u -- addr' u' )
     over c@ [char] $ - dup 4 u<      over c@ [char] $ - dup 4 u<
Line 464  hex Line 478  hex
  laddr# [ 0 , ] ;   laddr# [ 0 , ] ;
   
 : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception  : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
   >r sp@ r> swap >r       \ don't count xt! jaw      sp@ >r
   fp@ >r      fp@ >r
   lp@ >r      lp@ >r
   handler @ >r      handler @ >r
   rp@ handler !      rp@ handler !
   execute      execute
   r> handler ! rdrop rdrop rdrop 0 ;      r> handler ! rdrop rdrop rdrop 0 ;
   
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception  : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
     ?DUP IF      ?DUP IF
         [ here 9 cells ! ]          [ here 9 cells ! ] \ entry point for signal handler
         handler @ rp!          handler @ dup 0= IF
               2 (bye)
           THEN
           rp!
         r> handler !          r> handler !
         r> lp!          r> lp!
         r> fp!          r> fp!
         r> swap >r sp! r>          r> swap >r sp! drop r>
     THEN ;      THEN ;
   
 \ Bouncing is very fine,  \ Bouncing is very fine,
Line 487  hex Line 504  hex
 : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth  : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
 \ a throw without data or fp stack restauration  \ a throw without data or fp stack restauration
   ?DUP IF    ?DUP IF
     handler @ rp!        handler @ rp!
     r> handler !        r> handler !
     r> lp!        r> lp!
     rdrop        rdrop
     rdrop        rdrop
   THEN ;    THEN ;
   
 \ ?stack                                               23feb93py  \ ?stack                                               23feb93py
Line 546  Defer interpreter-notfound ( c-addr coun Line 563  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 570  Defer interpreter-notfound ( c-addr coun Line 587  Defer interpreter-notfound ( c-addr coun
 : ] ( -- ) \ core       right-bracket  : ] ( -- ) \ core       right-bracket
     ['] compiler     IS parser state on  ;      ['] compiler     IS parser state on  ;
   
 \ locals stuff needed for control structures  
   
 : compile-lp+! ( n -- ) \ gforth        compile-l-p-plus-store  
     dup negate locals-size +!  
     0 over = if  
     else -1 cells  over = if postpone lp-  
     else  1 floats over = if postpone lp+  
     else  2 floats over = if postpone lp+2  
     else postpone lp+!# dup ,  
     then then then then drop ;  
   
 : adjust-locals-size ( n -- ) \ gforth  
     \ 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  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  AConstant locals-list \ acts like a variable that contains
                       \ a linear list of locals names                        \ a linear list of locals names
Line 609  variable backedge-locals Line 610  variable backedge-locals
     dup orig?      dup orig?
     2 pick backedge-locals ! ; immediate      2 pick backedge-locals ! ; immediate
           
 \ locals list operations  
   
 : common-list ( list1 list2 -- list3 ) \ gforth-internal  
 \ 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 ) \ gforth-internal  
 \ true iff list1 is a sublist of list2  
  begin  
    2dup u<  
  while  
    @  
  repeat  
  = ;  
   
 : list-size ( list -- u ) \ gforth-internal  
 \ 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  \ Control Flow Stack
 \ orig, etc. have the following structure:  \ orig, etc. have the following structure:
 \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )  \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
Line 741  variable backedge-locals Line 693  variable backedge-locals
  POSTPONE ?branch >mark ; immediate restrict   POSTPONE ?branch >mark ; immediate restrict
   
 : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth   question-dupe-if  : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth   question-dupe-if
 \ This is the preferred alternative to the idiom "?DUP IF", since it can be  \G This is the preferred alternative to the idiom "?DUP IF", since it can be
 \ better handled by tools like stack checkers. Besides, it's faster.  \G better handled by tools like stack checkers. Besides, it's faster.
     POSTPONE ?dup-?branch >mark ;       immediate restrict      POSTPONE ?dup-?branch >mark ;       immediate restrict
   
 : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if  : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if
     POSTPONE ?dup-0=-?branch >mark ;       immediate restrict      POSTPONE ?dup-0=-?branch >mark ;       immediate restrict
   
 : then-like ( orig -- addr )  Defer then-like ( orig -- addr )
     swap -rot dead-orig =  : cs>addr ( orig/dest -- addr )  drop nip ;
     if  ' cs>addr IS then-like
         drop  
     else  
         dead-code @  
         if  
             set-locals-size-list dead-code off  
         else \ both live  
             dup list-size adjust-locals-size  
             locals-list @ common-list dup list-size adjust-locals-size  
             locals-list !  
         then  
     then ;  
   
 : THEN ( compilation orig -- ; run-time -- ) \ core  : THEN ( compilation orig -- ; run-time -- ) \ core
     dup orig?  then-like  >resolve ; immediate restrict      dup orig?  then-like  >resolve ; immediate restrict
Line 777  immediate restrict Line 718  immediate restrict
     1 cs-roll      1 cs-roll
     POSTPONE then ; immediate restrict      POSTPONE then ; immediate restrict
   
   Defer begin-like ( -- )
   ' noop IS begin-like
   
 : BEGIN ( compilation -- dest ; run-time -- ) \ core  : BEGIN ( compilation -- dest ; run-time -- ) \ core
     dead-code @ if      begin-like cs-push-part dest ; immediate restrict
         \ 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  
   
 \ AGAIN (the current control flow joins another, earlier one):  Defer again-like ( dest -- addr )
 \ If the dest-locals-list is not a subset of the current locals-list,  ' nip IS again-like
 \ issue a warning (see below). The following code is generated:  
 \ lp+!# (current-local-size - dest-locals-size)  
 \ branch <begin>  
   
 : again-like ( dest -- addr )  
     over list-size adjust-locals-size  
     swap check-begin  POSTPONE unreachable ;  
   
 : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext  : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
     dest? again-like  POSTPONE branch  <resolve ; immediate restrict      dest? again-like  POSTPONE branch  <resolve ; immediate restrict
   
 \ UNTIL (the current control flow may join an earlier one or continue):  Defer until-like
 \ Similar to AGAIN. The new locals-list and locals-size are the current  : until, ( list addr xt1 xt2 -- )  drop compile, <resolve drop ;
 \ ones. The following code is generated:  ' until, IS until-like
 \ ?branch-lp+!# <begin> (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 <resolve ( list adjustment ) ,  
     else ( list dest-addr adjustment )  
         drop  
         r> compile, <resolve  
         r> drop  
     then ( list )  
     check-begin ;  
   
 : UNTIL ( compilation dest -- ; run-time f -- ) \ core  : UNTIL ( compilation dest -- ; run-time f -- ) \ core
     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict      dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
Line 830  immediate restrict Line 745  immediate restrict
     POSTPONE again      POSTPONE again
     POSTPONE then ; immediate restrict      POSTPONE then ; immediate restrict
   
   
 \ counted loops  \ counted loops
   
 \ leave poses a little problem here  \ leave poses a little problem here
Line 947  Avariable leave-sp  leave-stack 3 cells Line 861  Avariable leave-sp  leave-stack 3 cells
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
   Defer exit-like ( -- )
   ' noop IS exit-like
   
 : EXIT ( compilation -- ; run-time nest-sys -- ) \ core  : EXIT ( compilation -- ; run-time nest-sys -- ) \ core
     0 adjust-locals-size      exit-like
     POSTPONE ;s      POSTPONE ;s
     POSTPONE unreachable ; immediate restrict      POSTPONE unreachable ; immediate restrict
   
Line 1011  Avariable leave-sp  leave-stack 3 cells Line 928  Avariable leave-sp  leave-stack 3 cells
     \ aborts if the last defined word was headerless      \ aborts if the last defined word was headerless
     last @ dup 0= abort" last word was headerless" cell+ ;      last @ dup 0= abort" last word was headerless" cell+ ;
   
 : immediate     immediate-mask lastflags cset ;  : immediate ( -- ) \ core
 : restrict      restrict-mask lastflags cset ;      immediate-mask lastflags cset ;
   : restrict ( -- ) \ gforth
       restrict-mask lastflags cset ;
   ' restrict alias compile-only ( -- ) \ gforth
   
 \ Header                                               23feb93py  \ Header                                               23feb93py
   
Line 1025  defer header ( -- ) \ gforth Line 945  defer header ( -- ) \ gforth
 ' (header) IS header  ' (header) IS header
   
 : string, ( c-addr u -- ) \ gforth  : string, ( c-addr u -- ) \ gforth
     \ puts down string as cstring      \G puts down string as cstring
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
 : header, ( c-addr u -- ) \ gforth  : header, ( c-addr u -- ) \ gforth
Line 1039  defer header ( -- ) \ gforth Line 959  defer header ( -- ) \ gforth
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
     name name-too-short? header, ;      name name-too-short? header, ;
 : input-stream ( -- )  \ general  : input-stream ( -- )  \ general
 \ switches back to getting the name from the input stream ;      \G switches back to getting the name from the input stream ;
     ['] input-stream-header IS (header) ;      ['] input-stream-header IS (header) ;
   
 ' input-stream-header IS (header)  ' input-stream-header IS (header)
Line 1075  create nextname-buffer 32 chars allot Line 995  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 1121  Create ???  0 , 3 c, char ? c, char ? c, Line 1042  Create ???  0 , 3 c, char ? c, char ? c,
   
 : (Constant)  Header reveal docon: cfa, ;  : (Constant)  Header reveal docon: cfa, ;
 : Constant ( w "name" -- ) \ core  : Constant ( w "name" -- ) \ core
       \G Defines constant @var{name}
       \G  
       \G @var{name} execution: @var{-- w}
     (Constant) , ;      (Constant) , ;
 : AConstant ( addr "name" -- ) \ gforth  : AConstant ( addr "name" -- ) \ gforth
     (Constant) A, ;      (Constant) A, ;
Line 1165  AVariable current ( -- addr ) \ gforth Line 1089  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 1175  AVariable current ( -- addr ) \ gforth Line 1099  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 1188  struct Line 1112  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 1225  end-struct interpret/compile-struct Line 1149  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
     \ 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
     \ get compilation semantics of name      \G @var{w xt} is the compilation token wor 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 1248  end-struct interpret/compile-struct Line 1175  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 1265  end-struct interpret/compile-struct Line 1192  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 1285  end-struct interpret/compile-struct Line 1214  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 1310  Variable warnings ( -- addr ) \ gforth Line 1247  Variable warnings ( -- addr ) \ gforth
 G -1 warnings T !  G -1 warnings T !
   
 : check-shadow  ( addr count wid -- )  : check-shadow  ( addr count wid -- )
 \ prints a warning if the string is already present in the wordlist  \G prints a warning if the string is already present in the wordlist
  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if   >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
    ." redefined " name>string 2dup type     ." redefined " name>string 2dup type
    compare 0<> if     compare 0<> if
Line 1327  G -1 warnings T ! Line 1264  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 1422  Defer key ( -- c ) \ core Line 1359  Defer key ( -- c ) \ core
   1 loadline +!    1 loadline +!
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- ) \ core-ext  : query   ( -- ) \ core-ext
     \ obsolescent      \G obsolescent
     loadfile off  blk off  refill drop ;      tib /line accept #tib ! 0 >in ! ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1502  create pathfilenamebuf 256 chars allot \ Line 1439  create pathfilenamebuf 256 chars allot \
 \   THEN ;  \   THEN ;
   
 : absolut-path? ( addr u -- flag ) \ gforth  : absolut-path? ( addr u -- flag ) \ gforth
     \ a path is absolute, if it starts with a / or a ~ (~ expansion),      \G a path is absolute, if it starts with a / or a ~ (~ expansion),
     \ or if it is in the form ./* or ../*, extended regexp: [/~]|./|../      \G or if it is in the form ./* or ../*, extended regexp: ^[/~]|./|../
     \ Pathes simply containing a / are not absolute!      \G Pathes simply containing a / are not absolute!
     over c@ '/ = >r      over c@ '/ = >r
     over c@ '~ = >r      over c@ '~ = >r
     2dup 2 min S" ./" compare 0= >r      2dup 2 min S" ./" compare 0= >r
Line 1513  create pathfilenamebuf 256 chars allot \ Line 1450  create pathfilenamebuf 256 chars allot \
 \   [char] / scan nip 0<> ;      \   [char] / scan nip 0<> ;    
   
 : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth  : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth
     \ opens a file for reading, searching in the path for it (unless      \G opens a file for reading, searching in the path for it (unless
     \ the filename contains a slash); c-addr2 u2 is the full filename      \G the filename contains a slash); c-addr2 u2 is the full filename
     \ (valid until the next call); if the file is not found (or in      \G (valid until the next call); if the file is not found (or in
     \ case of other errors for each try), -38 (non-existant file) is      \G case of other errors for each try), -38 (non-existant file) is
     \ thrown. Opening for other access modes makes little sense, as      \G thrown. Opening for other access modes makes little sense, as
     \ the path will usually contain dirs that are only readable for      \G the path will usually contain dirs that are only readable for
     \ the user      \G the user
     \ !! use file-status to determine access mode?      \ !! use file-status to determine access mode?
     2dup absolut-path?      2dup absolut-path?
     if \ the filename contains a slash      if \ the filename contains a slash
Line 1550  create image-included-files  1 , A, ( po Line 1487  create image-included-files  1 , A, ( po
 \ points to ALLOTed objects, so it survives a save-system  \ points to ALLOTed objects, so it survives a save-system
   
 : loadfilename ( -- a-addr )  : loadfilename ( -- a-addr )
     \ a-addr 2@ produces the current file name ( c-addr u )      \G a-addr 2@ produces the current file name ( c-addr u )
     included-files 2@ drop loadfilename# @ 2* cells + ;      included-files 2@ drop loadfilename# @ 2* cells + ;
   
 : sourcefilename ( -- c-addr u ) \ gforth  : sourcefilename ( -- c-addr u ) \ gforth
     \ the name of the source file which is currently the input      \G the name of the source file which is currently the input
     \ source.  The result is valid only while the file is being      \G source.  The result is valid only while the file is being
     \ loaded.  If the current input source is no (stream) file, the      \G loaded.  If the current input source is no (stream) file, the
     \ result is undefined.      \G result is undefined.
     loadfilename 2@ ;      loadfilename 2@ ;
   
 : sourceline# ( -- u ) \ gforth         sourceline-number  : sourceline# ( -- u ) \ gforth         sourceline-number
     \ the line number of the line that is currently being interpreted      \G the line number of the line that is currently being interpreted
     \ from a (stream) file. The first line has the number 1. If the      \G from a (stream) file. The first line has the number 1. If the
     \ current input source is no (stream) file, the result is      \G current input source is no (stream) file, the result is
     \ undefined.      \G undefined.
     loadline @ ;      loadline @ ;
   
 : init-included-files ( -- )  : init-included-files ( -- )
Line 1572  create image-included-files  1 , A, ( po Line 1509  create image-included-files  1 , A, ( po
     image-included-files 2@ nip included-files 2! ;      image-included-files 2@ nip included-files 2! ;
   
 : included? ( c-addr u -- f ) \ gforth  : included? ( c-addr u -- f ) \ gforth
     \ true, iff filename c-addr u is in included-files      \G true, iff filename c-addr u is in included-files
     included-files 2@ 0      included-files 2@ 0
     ?do ( c-addr u addr )      ?do ( c-addr u addr )
         dup >r 2@ 2over compare 0=          dup >r 2@ 2over compare 0=
Line 1585  create image-included-files  1 , A, ( po Line 1522  create image-included-files  1 , A, ( po
     2drop drop false ;      2drop drop false ;
   
 : add-included-file ( c-addr u -- ) \ gforth  : add-included-file ( c-addr u -- ) \ gforth
     \ add name c-addr u to included-files      \G add name c-addr u to included-files
     included-files 2@ 2* cells 2 cells extend-mem      included-files 2@ 2* cells 2 cells extend-mem
     2/ cell / included-files 2!      2/ cell / included-files 2!
     2! ;      2! ;
Line 1594  create image-included-files  1 , A, ( po Line 1531  create image-included-files  1 , A, ( po
 \    2* cells + 2! ;  \    2* cells + 2! ;
   
 : included1 ( i*x file-id c-addr u -- j*x ) \ gforth  : included1 ( i*x file-id c-addr u -- j*x ) \ gforth
     \ include the file file-id with the name given by c-addr u      \G include the file file-id with the name given by c-addr u
     loadfilename# @ >r      loadfilename# @ >r
     save-mem add-included-file ( file-id )      save-mem add-included-file ( file-id )
     included-files 2@ nip 1- loadfilename# !      included-files 2@ nip 1- loadfilename# !
Line 1606  create image-included-files  1 , A, ( po Line 1543  create image-included-files  1 , A, ( po
     open-path-file included1 ;      open-path-file included1 ;
   
 : required ( i*x addr u -- j*x ) \ gforth  : required ( i*x addr u -- j*x ) \ gforth
     \ include the file with the name given by addr u, if it is not      \G include the file with the name given by addr u, if it is not
     \ included already. Currently this works by comparing the name of      \G included already. Currently this works by comparing the name of
     \ the file (with path) against the names of earlier included      \G the file (with path) against the names of earlier included
     \ files; however, it would probably be better to fstat the file,      \G files; however, it would probably be better to fstat the file,
     \ and compare the device and inode. The advantages would be: no      \G and compare the device and inode. The advantages would be: no
     \ problems with several paths to the same file (e.g., due to      \G problems with several paths to the same file (e.g., due to
     \ links) and we would catch files included with include-file and      \G links) and we would catch files included with include-file and
     \ write a require-file.      \G write a require-file.
     open-path-file 2dup included?      open-path-file 2dup included?
     if      if
         2drop close-file throw          2drop close-file throw
Line 1678  create image-included-files  1 , A, ( po Line 1615  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 1792  Variable argc Line 1731  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 1874  Defer 'cold ' noop IS 'cold Line 1813  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@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off
   rp@ r0 !  fp@ f0 !  ['] cold catch DoError bye ;    rp@ r0 !  fp@ f0 !  ['] cold catch DoError bye ;
   
Removed from v.1.1  
changed lines
  Added in v.1.8

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