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

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

version 1.60, 1996/07/16 20:57:11 version 1.63, 1996/09/10 16:08:39
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?  
 ' compile-only 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 529  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 601  variable backedge-locals Line 603  variable backedge-locals
     0 backedge-locals ! ; immediate      0 backedge-locals ! ; immediate
   
 : ASSUME-LIVE ( orig -- orig ) \ gforth  : ASSUME-LIVE ( orig -- orig ) \ gforth
     \ used immediateliy before a BEGIN that is not reachable from      \ used immediatly before a BEGIN that is not reachable from
     \ above.  causes the BEGIN to assume that the same locals are live      \ above.  causes the BEGIN to assume that the same locals are live
     \ as at the orig point      \ as at the orig point
     dup orig?      dup orig?
Line 639  variable backedge-locals Line 641  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 958  Avariable leave-sp  leave-stack 3 cells Line 960  Avariable leave-sp  leave-stack 3 cells
 : ," ( "string"<"> -- ) [char] " parse  : ," ( "string"<"> -- ) [char] " parse
   here over char+ allot  place align ;    here over char+ allot  place align ;
 : "lit ( -- addr )  : "lit ( -- addr )
   r> r> dup count + aligned >r swap >r ;               restrict    r> r> dup count + aligned >r swap >r ;
 : (.")     "lit count type ;                           restrict  : (.")     "lit count type ;
 : (S")     "lit count ;                                restrict  : (S")     "lit count ;
 : 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
Line 1100  Create ???  0 , 3 c, char ? c, char ? c, Line 1102  Create ???  0 , 3 c, char ? c, char ? c,
 : dodoes,  ( -- )  : dodoes,  ( -- )
   here /does-handler allot does-handler! ;    here /does-handler allot does-handler! ;
   
 : Create ( -- ) \ core  : Create ( "name" -- ) \ core
     Header reveal dovar: cfa, ;      Header reveal dovar: cfa, ;
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
 : Variable ( -- ) \ core  : Variable ( "name" -- ) \ core
     Create 0 , ;      Create 0 , ;
 : AVariable ( -- ) \ gforth  : AVariable ( "name" -- ) \ gforth
     Create 0 A, ;      Create 0 A, ;
 : 2VARIABLE ( "name" -- ) \ double  : 2VARIABLE ( "name" -- ) \ double
     create 0 , 0 , ;      create 0 , 0 , ;
           
 : User  : User ( "name" -- ) \ gforth
     Variable ;      Variable ;
 : AUser  : AUser ( "name" -- ) \ gforth
     AVariable ;      AVariable ;
   
 : (Constant)  Header reveal docon: cfa, ;  : (Constant)  Header reveal docon: cfa, ;
 : Constant ( w -- ) \ core  : Constant ( w "name" -- ) \ core
     (Constant) , ;      (Constant) , ;
 : AConstant ( addr -- ) \ gforth  : AConstant ( addr "name" -- ) \ gforth
     (Constant) A, ;      (Constant) A, ;
   
 : 2Constant ( d -- ) \ double  : 2Constant ( w1 w2 "name" -- ) \ double
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
     DOES> ( -- w1 w2 )      DOES> ( -- w1 w2 )
Line 1131  Create ???  0 , 3 c, char ? c, char ? c, Line 1133  Create ???  0 , 3 c, char ? c, char ? c,
           
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : Defer ( -- ) \ gforth  : Defer ( "name" -- ) \ gforth
     \ !! shouldn't it be initialized with abort or something similar?      \ !! shouldn't it be initialized with abort or something similar?
     Header Reveal dodefer: cfa,      Header Reveal dodefer: cfa,
     ['] noop A, ;      ['] noop A, ;
Line 1148  Create ???  0 , 3 c, char ? c, char ? c, Line 1150  Create ???  0 , 3 c, char ? c, char ? c,
 defer :-hook ( sys1 -- sys2 )  defer :-hook ( sys1 -- sys2 )
 defer ;-hook ( sys2 -- sys1 )  defer ;-hook ( sys2 -- sys1 )
   
 : : ( -- colon-sys ) \ core     colon  : : ( "name" -- colon-sys ) \ core      colon
     Header docol: cfa, defstart ] :-hook ;      Header docol: cfa, defstart ] :-hook ;
 : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core     semicolon  : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core     semicolon
     ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict      ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
Line 1199  G forth-wordlist current T ! Line 1201  G forth-wordlist current T !
   
 \ higher level parts of find  \ higher level parts of find
   
 : special? ( xt -- flag )  ( struct )
   0 >body cell
     1 cells: field interpret/compile-int
     1 cells: field interpret/compile-comp
   end-struct interpret/compile-struct
   
   : interpret/compile? ( xt -- flag )
     >does-code ['] S" >does-code = ;      >does-code ['] S" >does-code = ;
   
 : xt>i ( xt -- xt )  : (cfa>int) ( cfa -- xt )
     dup special?  IF  >body  @  THEN ;      dup interpret/compile?
       if
           interpret/compile-int @
       then ;
   
 : 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
           (cfa>int)
       then ;
   
   : name>int ( nfa -- xt ) \ gforth
       (name>x) (x>int) ;
   
 : xt>s ( xt -- xt )  : name?int ( nfa -- xt ) \ gforth
     dup special?  IF  >body  state @ IF  cell+  THEN  @  THEN ;      \ like name>int, but throws an error if compile-only
       (name>x) restrict-mask and
       if
           compile-only-error \ does not return
       then
       (cfa>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  ;          interpret/compile-comp @
       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+ ;
   
   : (name>intn) ( nfa -- xt +-1 )
       (name>x) tuck (x>int) ( b xt )
       swap immediate-mask and flag-sign ;
   
   : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
       \ xt is the interpretation semantics
       (search-wordlist) dup if
           (name>intn)
       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 = flag-sign
           else
               (name>intn)
           then
       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 1568  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 1586  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 1696  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.63

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