Diff for /gforth/Attic/kernal.fs between versions 1.60 and 1.61

version 1.60, 1996/07/16 20:57:11 version 1.61, 1996/08/21 14:58:42
Line 160  $80 constant alias-mask \ set when the w Line 160  $80 constant alias-mask \ set when the w
 $40 constant immediate-mask  $40 constant immediate-mask
 $20 constant restrict-mask  $20 constant restrict-mask
   
 : (name>)  ( nfa+cell -- cfa )  : ((name>))  ( nfa -- cfa )
     1 cells - name>string +  cfaligned ;      name>string +  cfaligned ;
 : name>    ( nfa -- cfa ) \ gforth  
     cell+  : (name>x) ( nfa -- cfa b )
     dup  (name>) swap  c@ alias-mask and 0= IF  @ THEN ;      \ cfa is an intermediate cfa and b is the flags byte of nfa
       dup ((name>))
 \ (find)                                               17dec92py      swap cell+ c@ dup alias-mask and 0=
       IF
 \ : (find) ( addr count nfa1 -- nfa2 / false )          swap @ swap
 \   BEGIN  dup  WHILE  dup >r      THEN ;
 \          name>string dup >r 2over r> =  
 \          IF  -text  0= IF  2drop r> EXIT  THEN  
 \          ELSE  2drop drop  THEN  r> @  
 \   REPEAT nip nip ;  
   
 \ place bounds                                         13feb93py  \ place bounds                                         13feb93py
   
Line 182  $20 constant restrict-mask Line 178  $20 constant restrict-mask
 : bounds ( beg count -- end beg ) \ gforth  : bounds ( beg count -- end beg ) \ gforth
     over + swap ;      over + swap ;
   
   : save-mem      ( addr1 u -- addr2 u ) \ gforth
       \ copy a memory block into a newly allocated region in the heap
       swap >r
       dup allocate throw
       swap 2dup r> -rot move ;
   
   : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
       \ extend memory block allocated from the heap by u aus
       \ the (possibly reallocated piece is addr2 u2, the extension is at addr
       over >r + dup >r resize throw
       r> over r> + -rot ;
   
 \ input stream primitives                              23feb93py  \ input stream primitives                              23feb93py
   
 : tib ( -- c-addr ) \ core-ext  : tib ( -- c-addr ) \ core-ext
Line 267  Defer source ( -- addr count ) \ core Line 275  Defer source ( -- addr count ) \ core
   
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
 : postpone ( "name" -- ) \ core  
   name sfind dup 0= abort" Can't compile "  
   0> IF  compile,  ELSE  postpone (compile) A,  THEN ; immediate restrict  
   
 : special: ( interp comp "name" -- )  \ not the most efficient implementation of POSTPONE, but simple
   : POSTPONE ( -- ) \ core
       COMP' swap POSTPONE aliteral compile, ; immediate restrict
   
   : interpret/compile: ( interp-xt comp-xt "name" -- )
     Create immediate swap A, A,      Create immediate swap A, A,
     DOES>  state @ IF  cell+  THEN  perform ;  DOES>
       abort" executed primary cfa of an interpret/compile: word" ;
   \    state @ IF  cell+  THEN  perform ;
   
 \ Use (compile) for the old behavior of compile!  \ Use (compile) for the old behavior of compile!
   
Line 504  Defer interpreter-notfound ( c-addr coun Line 515  Defer interpreter-notfound ( c-addr coun
 ' no.extensions IS compiler-notfound  ' no.extensions IS compiler-notfound
 ' no.extensions IS interpreter-notfound  ' no.extensions IS interpreter-notfound
   
 : compile-only ( ... -- )  : compile-only-error ( ... -- )
     -&14 throw ;      -&14 throw ;
 Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt?  Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt?
 ' compile-only IS interpret-special  ' compile-only-error IS interpret-special
   
 : interpret ( ?? -- ?? ) \ gforth  : interpret ( ?? -- ?? ) \ gforth
     \ interpret/compile the (rest of the) input buffer      \ interpret/compile the (rest of the) input buffer
Line 520  Defer interpret-special ( c-addr u xt -- Line 531  Defer interpret-special ( c-addr u xt --
   
 \ interpreter compiler                                 30apr92py  \ interpreter compiler                                 30apr92py
   
 : interpreter  ( c-addr u -- ) \ gforth  \ not the most efficient implementations of interpreter and compiler
     \ interpretation semantics for the name/number c-addr u  : interpreter ( c-addr u -- ) 
     2dup (sfind) dup      2dup find-name dup
     IF      if
         1 and          nip nip name>int execute
         IF \ not restricted to compile state?      else
             nip nip execute EXIT          drop
         THEN          2dup 2>r snumber?
         interpret-special exit  
     THEN  
     drop  
     2dup 2>r snumber?  
     IF  
         2rdrop  
     ELSE  
         2r> interpreter-notfound  
     THEN ;  
   
 ' interpreter  IS  parser  
   
 : compiler     ( c-addr u -- ) \ gforth  
     \ compilation semantics for the name/number c-addr u  
     2dup (sfind) dup  
     IF  
         0>  
         IF          IF
             nip nip execute EXIT              2rdrop
           ELSE
               2r> interpreter-notfound
         THEN          THEN
         compile, 2drop EXIT      then ;
     THEN  
     drop  : compiler ( c-addr u -- )
     2dup snumber? dup      2dup find-name dup
     IF      if ( c-addr u nfa )
         0>          nip nip name>comp execute
       else
           drop
           2dup snumber? dup
         IF          IF
             swap postpone Literal              0>
               IF
                   swap postpone Literal
               THEN
               postpone Literal
               2drop
           ELSE
               drop compiler-notfound
         THEN          THEN
         postpone Literal      then ;
         2drop  
     ELSE  ' interpreter  IS  parser
         drop compiler-notfound  
     THEN ;  
   
 : [ ( -- ) \ core       left-bracket  : [ ( -- ) \ core       left-bracket
     ['] interpreter  IS parser state off ; immediate      ['] interpreter  IS parser state off ; immediate
Line 639  variable backedge-locals Line 643  variable backedge-locals
    over 0<>     over 0<>
  while   while
    over     over
    name> >body @ max     ((name>)) >body @ max
    swap @ swap ( get next )     swap @ swap ( get next )
  repeat   repeat
  faligned nip ;   faligned nip ;
Line 1199  G forth-wordlist current T ! Line 1203  G forth-wordlist current T !
   
 \ higher level parts of find  \ higher level parts of find
   
 : special? ( xt -- flag )  ( struct )
     >does-code ['] S" >does-code = ;  0 >body cell
     1 cells: field special-interpretation
     1 cells: field special-compilation
   end-struct special-struct
   
 : xt>i ( xt -- xt )  : interpret/compile? ( xt -- flag )
     dup special?  IF  >body  @  THEN ;      >does-code ['] S" >does-code = ;
   
 : xt>c ( xt -- xt )  : (x>int) ( cfa b -- xt )
     dup special?  IF  >body  cell+  @  THEN ;      \ get interpretation semantics of name
       restrict-mask and
       if
           drop ['] compile-only-error
       else
           dup interpret/compile?
           if
               special-interpretation @
           then
       then ;
   
 : xt>s ( xt -- xt )  : name>int ( nfa -- xt ) \ gforth
     dup special?  IF  >body  state @ IF  cell+  THEN  @  THEN ;      (name>x) (x>int) ;
   
 : found ( nfa -- cfa n ) \ gforth  : name>comp ( nfa -- w xt ) \ gforth
     cell+  dup c@ >r  (name>)      \ get compilation semantics of name
     r@ alias-mask     and  0= IF  @       THEN  -1      (name>x) >r dup interpret/compile?
     r@ restrict-mask  and     IF  1-      THEN      if
     r> immediate-mask and     IF  negate  THEN  ;          special-compilation @
       then
       r> immediate-mask and if
           ['] execute
       else
           ['] compile,
       then ;
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nfa / false )
     dup wordlist-map @ find-method perform ;      dup wordlist-map @ find-method perform ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search  : flag-sign ( f -- 1|-1 )
     (search-wordlist) dup  IF  found  swap xt>s swap  THEN ;      \ true becomes 1, false -1
       0= 2* 1+ ;
   
   : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
      \ xt is the interpretation semantics
       (search-wordlist) dup if
           (name>x) tuck (x>int) ( b xt )
           swap immediate-mask and flag-sign
       then ;
   
 : (sfind) ( c-addr u -- xt n / 0 )  : find-name ( c-addr u -- nfa/0 )
     lookup @ (search-wordlist) dup IF  found  THEN ;      lookup @ (search-wordlist) ;
   
 : sfind ( c-addr u -- xt n / 0 ) \ gforth  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
     lookup @ search-wordlist ;      find-name dup
       if ( nfa )
           state @
           if
               name>comp ['] execute =
           else
               (name>x) tuck (x>int)
               swap immediate-mask and
           then
           flag-sign
       then ;
   
 : find   ( addr -- cfa +-1 / string false ) \ core,search  : find ( c-addr -- xt +-1 / c-addr 0 ) \ core
     dup count sfind dup IF      dup count sfind dup
       if
         rot drop          rot drop
     THEN      then ;
     dup 1 and 0=  IF  2/  THEN ;  
   
 : (')    ( "name" -- xt ) \ gforth      paren-tick  : (') ( "name" -- nfa ) \ gforth
     name (sfind) 0= IF  -&13 bounce THEN  ;      name find-name dup 0=
 : [(')]  ( compilation "name" -- ; run-time -- addr ) \ gforth  bracket-paren-tick      IF
           drop -&13 bounce
       THEN  ;
   
   : [(')]  ( compilation "name" -- ; run-time -- nfa ) \ gforth   bracket-paren-tick
     (') postpone ALiteral ; immediate restrict      (') postpone ALiteral ; immediate restrict
   
 : '    ( "name" -- xt ) \ core  tick  : '    ( "name" -- xt ) \ core  tick
     (') xt>i ;      (') name>int ;
 : [']  ( compilation "name" -- ; run-time -- addr ) \ core      bracket-tick  : [']  ( compilation "name" -- ; run-time -- xt ) \ core        bracket-tick
     ' postpone ALiteral ; immediate restrict      ' postpone ALiteral ; immediate restrict
   
 : C'    ( "name" -- xt ) \ gforth       c-tick  : COMP'    ( "name" -- w xt ) \ gforth  c-tick
     (') xt>c ;      (') name>comp ;
 : [C']  ( compilation "name" -- ; run-time -- addr ) \ gforth   bracket-c-tick  : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth        bracket-comp-tick
     C' postpone ALiteral ; immediate restrict      COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
   
 : S'    ( "name" -- xt ) \ gforth       s-tick  
     (') xt>s ;  
 : [S']  ( compilation "name" -- ; run-time -- addr ) \ gforth   bracket-s-tick  
     S' postpone ALiteral ; immediate restrict  
   
 \ reveal words  \ reveal words
   
Line 1519  create image-included-files  1 , A, ( po Line 1558  create image-included-files  1 , A, ( po
     loadline @ ;      loadline @ ;
   
 : init-included-files ( -- )  : init-included-files ( -- )
     image-included-files 2@ 2* cells save-string drop ( addr )      image-included-files 2@ 2* cells save-mem drop ( addr )
     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
Line 1537  create image-included-files  1 , A, ( po Line 1576  create image-included-files  1 , A, ( po
   
 : add-included-file ( c-addr u -- ) \ gforth  : add-included-file ( c-addr u -- ) \ gforth
     \ add name c-addr u to included-files      \ add name c-addr u to included-files
     included-files 2@ tuck 1+ 2* cells resize throw      included-files 2@ 2* cells 2 cells extend-mem
     swap 2dup 1+ included-files 2!      2/ cell / included-files 2!
     2* cells + 2! ;      2! ;
   \    included-files 2@ tuck 1+ 2* cells resize throw
 : save-string           ( addr1 u -- addr2 u ) \ gforth  \    swap 2dup 1+ included-files 2!
     \ !! not a string, but a memblock word  \    2* cells + 2! ;
     swap >r  
     dup allocate throw  
     swap 2dup r> -rot move ;  
   
 : 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      \ include the file file-id with the name given by c-addr u
     loadfilename# @ >r      loadfilename# @ >r
     save-string add-included-file ( file-id )      save-mem add-included-file ( file-id )
     included-files 2@ nip 1- loadfilename# !      included-files 2@ nip 1- loadfilename# !
     ['] include-file catch      ['] include-file catch
     r> loadfilename# !      r> loadfilename# !
Line 1650  max-errors 6 * cells allot Line 1686  max-errors 6 * cells allot
     \ print value in decimal representation      \ print value in decimal representation
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
   : hex. ( u -- ) \ gforth
       \ print value as unsigned hex number
       '$ emit base @ swap hex u. base ! ;
   
 : 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

Removed from v.1.60  
changed lines
  Added in v.1.61


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