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

version 1.3, 1996/09/24 19:15:03 version 1.9, 1996/12/28 17:19:25
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" -- ) \ gforth  : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
     Create immediate swap A, A,      Create immediate swap A, A,
Line 549  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 981  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 1074  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 1084  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 1097  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 1134  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
     \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 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 1157  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 1174  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 1194  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 1236  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 1331  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
     \G obsolescent      \G obsolescent
     loadfile off  blk off  refill drop ;      tib /line accept #tib ! 0 >in ! ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1587  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 1701  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 1783  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@ 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.9


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