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

Diff for /gforth/Attic/kernal.fs between versions 1.15 and 1.25

version 1.15, 1994/08/25 15:25:28 version 1.25, 1994/11/15 16:54:56
Line 1 Line 1
 \ KERNAL.FS    ANS figFORTH kernal                     17dec92py  \ KERNAL.FS    GNU FORTH kernal                        17dec92py
 \ $ID:  \ $ID:
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group  \ Copyright 1992 by the ANSI figForth Development Group
Line 66  DOES> ( n -- )  + c@ ; Line 66  DOES> ( n -- )  + c@ ;
       bl c,        bl c,
   LOOP ;    LOOP ;
   
   : chars ; immediate
   
 : A!    ( addr1 addr2 -- )  dup relon ! ;  : A!    ( addr1 addr2 -- )  dup relon ! ;
 : A,    ( addr -- )     here cell allot A! ;  : A,    ( addr -- )     here cell allot A! ;
Line 110  Defer source Line 110  Defer source
   
 \ (word)                                               22feb93py  \ (word)                                               22feb93py
   
 : scan   ( addr1 n1 char -- addr2 n2 )  >r  : scan   ( addr1 n1 char -- addr2 n2 )
   BEGIN  dup  WHILE  over c@ r@ <>  WHILE  1 /string      \ skip all characters not equal to char
   REPEAT  THEN  rdrop ;      >r
 : skip   ( addr1 n1 char -- addr2 n2 )  >r      BEGIN
   BEGIN  dup  WHILE  over c@ r@  =  WHILE  1 /string          dup
   REPEAT  THEN  rdrop ;      WHILE
           over c@ r@ <>
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   : skip   ( addr1 n1 char -- addr2 n2 )
       \ skip all characters equal to char
       >r
       BEGIN
           dup
       WHILE
           over c@ r@  =
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   
 : (word) ( addr1 n1 char -- addr2 n2 )  : (word) ( addr1 n1 char -- addr2 n2 )
   dup >r skip 2dup r> scan  nip - ;    dup >r skip 2dup r> scan  nip - ;
Line 138  Defer source Line 154  Defer source
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
   
 : capitalize ( addr -- addr )  : capitalize ( addr len -- addr len )
   dup count chars bounds    2dup chars chars bounds
   ?DO  I c@ toupper I c! 1 chars +LOOP ;    ?DO  I c@ toupper I c! 1 chars +LOOP ;
 : (name)  ( -- addr )  bl word ;  : (name) ( -- c-addr count )
 : sname ( -- c-addr count )  
     source 2dup >r >r >in @ /string (parse-white)      source 2dup >r >r >in @ /string (parse-white)
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
Line 158  Defer source Line 173  Defer source
 : [char] ( 'char' -- n )  char postpone Literal ; immediate  : [char] ( 'char' -- n )  char postpone Literal ; immediate
 ' [char] Alias Ascii immediate  ' [char] Alias Ascii immediate
   
 : (compile) ( -- )  r> dup cell+ >r @ A, ;  : (compile) ( -- )  r> dup cell+ >r @ compile, ;
 : postpone ( "name" -- )  : postpone ( "name" -- )
   name find dup 0= abort" Can't compile "    name sfind dup 0= abort" Can't compile "
   0> IF  A,  ELSE  postpone (compile) A,  THEN ;    0> IF  compile,  ELSE  postpone (compile) A,  THEN ;
                                              immediate restrict                                               immediate restrict
   
 \ Use (compile) for the old behavior of compile!  \ Use (compile) for the old behavior of compile!
Line 229  decimal Line 244  decimal
 Create spaces  bl 80 times \ times from target compiler! 11may93jaw  Create spaces  bl 80 times \ times from target compiler! 11may93jaw
 DOES>   ( u -- )  swap  DOES>   ( u -- )  swap
         0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;          0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
   Create backspaces  08 80 times \ times from target compiler! 11may93jaw
   DOES>   ( u -- )  swap
           0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
 hex  hex
 : space   1 spaces ;  : space   1 spaces ;
   
Line 326  Defer notfound ( c-addr count -- ) Line 344  Defer notfound ( c-addr count -- )
   
 : interpret  : interpret
     BEGIN      BEGIN
         ?stack sname dup          ?stack name dup
     WHILE      WHILE
         parser          parser
     REPEAT      REPEAT
     2drop ;      2drop ;
   
 \ sinterpreter scompiler                                 30apr92py  \ interpreter compiler                                 30apr92py
   
 : sinterpreter  ( c-addr u -- )   : interpreter  ( c-addr u -- ) 
     \ interpretation semantics for the name/number c-addr u      \ interpretation semantics for the name/number c-addr u
     2dup sfind dup      2dup sfind dup
     IF      IF
Line 352  Defer notfound ( c-addr count -- ) Line 370  Defer notfound ( c-addr count -- )
         2r> notfound          2r> notfound
     THEN ;      THEN ;
   
 ' sinterpreter  IS  parser  ' interpreter  IS  parser
   
 : scompiler     ( c-addr u -- )  : compiler     ( c-addr u -- )
     \ compilation semantics for the name/number c-addr u      \ compilation semantics for the name/number c-addr u
     2dup sfind dup      2dup sfind dup
     IF      IF
Line 377  Defer notfound ( c-addr count -- ) Line 395  Defer notfound ( c-addr count -- )
         drop notfound          drop notfound
     THEN ;      THEN ;
   
 : [     ['] sinterpreter  IS parser state off ; immediate  : [     ['] interpreter  IS parser state off ; immediate
 : ]     ['] scompiler     IS parser state on  ;  : ]     ['] compiler     IS parser state on  ;
   
 \ locals stuff needed for control structures  \ locals stuff needed for control structures
   
 : compile-lp+! ( n -- )  : compile-lp+! ( n -- )
     dup negate locals-size +!      dup negate locals-size +!
     0 over = if      0 over = if
     else -4 over = if postpone -4lp+!      else -1 cells  over = if postpone lp-
     else  8 over = if postpone  8lp+!      else  1 floats over = if postpone lp+
     else 16 over = if postpone 16lp+!      else  2 floats over = if postpone lp+2
     else postpone lp+!# dup ,      else postpone lp+!# dup ,
     then then then then drop ;      then then then then drop ;
   
Line 402  AConstant locals-list \ acts like a vari Line 420  AConstant locals-list \ acts like a vari
   
   
 variable dead-code \ true if normal code at "here" would be dead  variable dead-code \ true if normal code at "here" would be dead
   variable backedge-locals
 : unreachable ( -- )      \ contains the locals list that BEGIN will assume to be live on
 \ declares the current point of execution as unreachable      \ the back edge if the BEGIN is unreachable from above. Set by
  dead-code on ;      \ ASSUME-LIVE, reset by UNREACHABLE.
   
   : UNREACHABLE ( -- )
       \ declares the current point of execution as unreachable
       dead-code on
       0 backedge-locals ! ; immediate
   
   : ASSUME-LIVE ( orig -- orig )
       \ used immediateliy 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
       
 \ locals list operations  \ locals list operations
   
 : common-list ( list1 list2 -- list3 )  : common-list ( list1 list2 -- list3 )
Line 531  variable dead-code \ true if normal code Line 561  variable dead-code \ true if normal code
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 : AHEAD ( -- orig )  : AHEAD ( -- orig )
  POSTPONE branch >mark unreachable ; immediate restrict   POSTPONE branch >mark POSTPONE unreachable ; immediate restrict
   
 : IF ( -- orig )  : IF ( -- orig )
  POSTPONE ?branch >mark ; immediate restrict   POSTPONE ?branch >mark ; immediate restrict
Line 545  variable dead-code \ true if normal code Line 575  variable dead-code \ true if normal code
   
 : THEN ( orig -- )  : THEN ( orig -- )
     dup orig?      dup orig?
     dead-code @      dead-orig =
     if      if
         dead-orig =          >resolve drop
         if  
             >resolve drop  
         else  
             >resolve set-locals-size-list dead-code off  
         then  
     else      else
         dead-orig =          dead-code @
         if          if
             >resolve drop              >resolve set-locals-size-list dead-code off
         else \ both live          else \ both live
             over list-size adjust-locals-size              over list-size adjust-locals-size
             >resolve              >resolve
Line 578  variable dead-code \ true if normal code Line 603  variable dead-code \ true if normal code
   
 : BEGIN ( -- dest )  : BEGIN ( -- dest )
     dead-code @ if      dead-code @ if
         \ set up an assumption of the locals visible here          \ set up an assumption of the locals visible here.  if the
         \ currently we just take the top cs-item          \ users want something to be visible, they have to declare
         \ it would be more intelligent to take the top orig          \ that using ASSUME-LIVE
         \   but that can be arranged by the user          backedge-locals @ set-locals-size-list
         dup defstart <> if  
             dup cs-item?  
             2 pick  
         else  
             0  
         then  
         set-locals-size-list  
     then      then
     cs-push-part dest      cs-push-part dest
     dead-code off ; immediate restrict      dead-code off ; immediate restrict
Line 604  variable dead-code \ true if normal code Line 622  variable dead-code \ true if normal code
     POSTPONE branch      POSTPONE branch
     <resolve      <resolve
     check-begin      check-begin
     unreachable ; immediate restrict      POSTPONE unreachable ; immediate restrict
   
 \ UNTIL (the current control flow may join an earlier one or continue):  \ UNTIL (the current control flow may join an earlier one or continue):
 \ Similar to AGAIN. The new locals-list and locals-size are the current  \ Similar to AGAIN. The new locals-list and locals-size are the current
Line 736  Avariable leave-sp  leave-stack 3 cells Line 754  Avariable leave-sp  leave-stack 3 cells
 : EXIT ( -- )  : EXIT ( -- )
     0 adjust-locals-size      0 adjust-locals-size
     POSTPONE ;s      POSTPONE ;s
     unreachable ; immediate restrict      POSTPONE unreachable ; immediate restrict
   
 : ?EXIT ( -- )  : ?EXIT ( -- )
      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict       POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
Line 756  Avariable leave-sp  leave-stack 3 cells Line 774  Avariable leave-sp  leave-stack 3 cells
 : ."       state @  IF    postpone (.") ,"  align  : ."       state @  IF    postpone (.") ,"  align
                     ELSE  [char] " parse type  THEN  ;  immediate                      ELSE  [char] " parse type  THEN  ;  immediate
 : (        [char] ) parse 2drop ;                       immediate  : (        [char] ) parse 2drop ;                       immediate
 : \        source >in ! drop ;                          immediate  : \        blk @ IF  >in @ c/l / 1+ c/l * >in !  EXIT  THEN
              source >in ! drop ;                          immediate
   
 \ error handling                                       22feb93py  \ error handling                                       22feb93py
 \ 'abort thrown out!                                   11may93jaw  \ 'abort thrown out!                                   11may93jaw
Line 780  Avariable leave-sp  leave-stack 3 cells Line 799  Avariable leave-sp  leave-stack 3 cells
 \ information through global variables), but they are useful for dealing  \ information through global variables), but they are useful for dealing
 \ with existing/independent defining words  \ with existing/independent defining words
   
 defer header  defer (header)
   defer header     ' (header) IS header
   
 : name,  ( "name" -- )  : name,  ( "name" -- )
     name c@      name
     dup $1F u> -&19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is name too long? )
     1+ chars allot align ;      dup c,  here swap chars  dup allot  move  align ;
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
     \ !! this is f83-implementation-dependent      \ !! this is f83-implementation-dependent
     align here last !  -1 A,      align here last !  -1 A,
Line 793  defer header Line 813  defer header
   
 : input-stream ( -- )  \ general  : input-stream ( -- )  \ general
 \ switches back to getting the name from the input stream ;  \ 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)
   
 \ !! make that a 2variable  \ !! make that a 2variable
 create nextname-buffer 32 chars allot  create nextname-buffer 32 chars allot
Line 813  create nextname-buffer 32 chars allot Line 833  create nextname-buffer 32 chars allot
     dup $1F u> -&19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is name too long? )
     nextname-buffer c! ( c-addr )      nextname-buffer c! ( c-addr )
     nextname-buffer count move      nextname-buffer count move
     ['] nextname-header IS header ;      ['] nextname-header IS (header) ;
   
 : noname-header ( -- )  : noname-header ( -- )
     0 last !      0 last !
Line 821  create nextname-buffer 32 chars allot Line 841  create nextname-buffer 32 chars allot
   
 : noname ( -- ) \ general  : noname ( -- ) \ general
 \ the next defined word remains anonymous. The xt of that word is given by lastxt  \ the next defined word remains anonymous. The xt of that word is given by lastxt
     ['] noname-header IS header ;      ['] noname-header IS (header) ;
   
 : lastxt ( -- xt ) \ general  : lastxt ( -- xt ) \ general
 \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname  \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
Line 965  AVariable current Line 985  AVariable current
 Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,  Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,
   
 Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,  Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
 AVariable search       G forth-wordlist search T !  AVariable lookup       G forth-wordlist lookup T !
 G forth-wordlist current T !  G forth-wordlist current T !
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nfa / false )
   dup ( @ swap ) cell+ @ @ execute ;    dup cell+ @ @ execute ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 )  : search-wordlist  ( addr count wid -- 0 / xt +-1 )
   (search-wordlist) dup  IF  found  THEN ;    (search-wordlist) dup  IF  found  THEN ;
Line 991  Variable warnings  G -1 warnings T ! Line 1011  Variable warnings  G -1 warnings T !
  2drop 2drop ;   2drop 2drop ;
   
 : sfind ( c-addr u -- xt n / 0 )  : sfind ( c-addr u -- xt n / 0 )
     search @ search-wordlist ;      lookup @ search-wordlist ;
   
 : find   ( addr -- cfa +-1 / string false )  : find   ( addr -- cfa +-1 / string false )
     \ !! not ANS conformant: returns +-2 for restricted words      \ !! not ANS conformant: returns +-2 for restricted words
Line 1007  Variable warnings  G -1 warnings T ! Line 1027  Variable warnings  G -1 warnings T !
   
 : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;  : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;
   
 : '    ( "name" -- addr )  name find 0= if drop -&13 bounce then ;  : '    ( "name" -- addr )  name sfind 0= if -&13 bounce then ;
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate  : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
 07 constant #bell  07 constant #bell
 08 constant #bs  08 constant #bs
   09 constant #tab
 7F constant #del  7F constant #del
 0D constant #cr                \ the newline key code  0D constant #cr                \ the newline key code
   0C constant #ff
 0A constant #lf  0A constant #lf
   
 : bell  #bell emit ;  : bell  #bell emit ;
   
 : backspaces  0 ?DO  #bs emit  LOOP ;  \ : backspaces  0 ?DO  #bs emit  LOOP ;
 : >string  ( span addr pos1 -- span addr pos1 addr2 len )  : >string  ( span addr pos1 -- span addr pos1 addr2 len )
   over 3 pick 2 pick chars /string ;    over 3 pick 2 pick chars /string ;
 : type-rest ( span addr pos1 -- span addr pos1 back )  : type-rest ( span addr pos1 -- span addr pos1 back )
Line 1036  Variable warnings  G -1 warnings T ! Line 1058  Variable warnings  G -1 warnings T !
 : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;  : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;
 : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;  : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;
   
 Create crtlkeys  Create ctrlkeys
   ] false false back  false  false false forw  false    ] false false back  false  false false forw  false
     ?del  false (ret) false  false (ret) false false      ?del  false (ret) false  false (ret) false false
     false false false false  false false false false      false false false false  false false false false
     false false false false  false false false false [      false false false false  false false false false [
   
   defer everychar
   ' noop IS everychar
   
 : decode ( max span addr pos1 key -- max span addr pos2 flag )  : decode ( max span addr pos1 key -- max span addr pos2 flag )
     everychar
   dup #del = IF  drop #bs  THEN  \ del is rubout    dup #del = IF  drop #bs  THEN  \ del is rubout
   dup bl <   IF  cells crtlkeys + @ execute  EXIT  THEN    dup bl <   IF  cells ctrlkeys + @ execute  EXIT  THEN
   >r 2over = IF  rdrop bell 0 EXIT  THEN    >r 2over = IF  rdrop bell 0 EXIT  THEN
   r> (ins) 0 ;    r> (ins) 0 ;
   
Line 1060  Create crtlkeys Line 1086  Create crtlkeys
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
 DEFER type      \ defer type for a output buffer or fast  Defer type      \ defer type for a output buffer or fast
                 \ screen write                  \ screen write
   
 \ : (type) ( addr len -- )  \ : (type) ( addr len -- )
 \   bounds ?DO  I c@ emit  LOOP ;  \   bounds ?DO  I c@ emit  LOOP ;
   
 ' (TYPE) IS Type  ' (type) IS Type
   
 DEFER Emit  Defer emit
   
 ' (Emit) IS Emit  ' (Emit) IS Emit
   
   Defer key
   ' (key) IS key
   
 \ : form  ( -- rows cols )  &24 &80 ;  \ : form  ( -- rows cols )  &24 &80 ;
 \ form should be implemented using TERMCAPS or CURSES  \ form should be implemented using TERMCAPS or CURSES
 \ : rows  form drop ;  \ : rows  form drop ;
Line 1080  DEFER Emit Line 1109  DEFER Emit
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
 : refill ( -- flag )  : refill ( -- flag )
     blk @  IF  1 blk +!  true  EXIT  THEN
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    \ dup file-position throw linestart 2!    IF    read-line throw
         read-line throw  
   ELSE  loadline @ 0< IF 2drop false EXIT THEN    ELSE  loadline @ 0< IF 2drop false EXIT THEN
         accept true          accept true
   THEN    THEN
   1 loadline +!    1 loadline +!
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- )  0 loadfile ! refill drop ;  : Query  ( -- )  loadfile off  blk off  refill drop ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 1119  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1148  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
 : push-file  ( -- )  r>  : push-file  ( -- )  r>
   ( linestart 2@ >r >r ) loadline @ >r loadfile @ >r    loadline @ >r loadfile @ >r
   blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;    blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;
   
 : pop-file   ( -- )  r>  : pop-file   ( throw-code -- throw-code )
   r> >in !  r> #tib !  r> >tib ! r> blk !    dup IF
   r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ;           source >in @ loadline @ loadfilename 2@
            error-stack dup @ dup 1+
            max-errors 1- min error-stack !
            6 * cells + cell+
            5 cells bounds swap DO
                               I !
            -1 cells +LOOP
     THEN
     r>
     r> >in !  r> #tib !  r> >tib !  r> blk !
     r> loadfile ! r> loadline !  >r ;
   
   : read-loop ( i*x -- j*x )
     BEGIN  refill  WHILE  interpret  REPEAT ;
   
 : include-file ( i*x fid -- j*x )  : include-file ( i*x fid -- j*x )
   push-file  loadfile !    push-file  loadfile !
   0 loadline ! blk off    0 loadline ! blk off  ['] read-loop catch
   BEGIN  refill  WHILE  interpret  REPEAT    loadfile @ close-file swap 2dup or
   loadfile @ close-file throw    pop-file  drop throw throw ;
   pop-file ;  
   create pathfilenamebuf 256 chars allot \ !! make this grow on demand
   
   : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 )
       \ opens a file for reading, searching in the path for it; c-addr2
       \ u2 is the full filename (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 thrown. Opening for other access modes
       \ makes little sense, as the path will usually contain dirs that
       \ are only readable for the user
       \ !! check for "/", "./", "../" in original filename; check for "~/"?
       pathdirs 2@ 0
       ?DO ( c-addr1 u1 dirnamep )
           dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
           2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
           pathfilenamebuf over r> + dup >r r/o open-file 0=
           if ( addr u file-id )
               nip nip r> rdrop 0 leave
           then
           rdrop drop r> cell+ cell+
       LOOP
       0<> -&38 and throw ( file-id u2 )
       pathfilenamebuf swap ;
   
 : included ( i*x addr u -- j*x )  : included ( i*x addr u -- j*x )
     loadfilename 2@ >r >r      loadfilename 2@ >r >r
     dup allocate throw over loadfilename 2!      open-path-file ( file-id c-addr2 u2 )
     over loadfilename 2@ move      dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 )
     r/o open-file throw include-file      drop loadfilename 2@ move
       ['] include-file catch
     \ don't free filenames; they don't take much space      \ don't free filenames; they don't take much space
     \ and are used for debugging      \ and are used for debugging
     r> r> loadfilename 2! ;      r> r> loadfilename 2!  throw ;
   
 \ HEX DECIMAL                                           2may93jaw  \ HEX DECIMAL                                           2may93jaw
   
Line 1150  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1215  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ DEPTH                                                 9may93jaw  \ DEPTH                                                 9may93jaw
   
 : depth ( -- +n )  sp@ s0 @ swap - cell / ;  : depth ( -- +n )  sp@ s0 @ swap - cell / ;
   : clearstack ( ... -- )  s0 @ sp! ;
   
 \ INCLUDE                                               9may93jaw  \ INCLUDE                                               9may93jaw
   
 : include  ( "file" -- )  : include  ( "file" -- )
   bl word count included ;    name included ;
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
Line 1176  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1242  create nl$ 1 c, A c, 0 c, \ gnu includes
   push-file  dup #tib ! >tib @ swap move    push-file  dup #tib ! >tib @ swap move
   >in off blk off loadfile off -1 loadline !    >in off blk off loadfile off -1 loadline !
   
   BEGIN  interpret  >in @ #tib @ u>= UNTIL  \  BEGIN  interpret  >in @ #tib @ u>= UNTIL
     ['] interpret catch
   pop-file ;    pop-file throw ;
   
   
 : abort -1 throw ;  : abort -1 throw ;
Line 1196  Defer .status Line 1262  Defer .status
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
   
   8 Constant max-errors
   Variable error-stack  0 error-stack !
   max-errors 6 * cells allot
   \ format of one cell:
   \ source ( addr u )
   \ >in
   \ line-number
   \ Loadfilename ( addr u )
   
 : dec. ( n -- )  : dec. ( n -- )
     \ print value in decimal representation      \ print value in decimal representation
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
 : typewhite ( addr u -- )  : typewhite ( addr u -- )
     \ like type, but white space is printed instead of the characters      \ like type, but white space is printed instead of the characters
     0 ?do      bounds ?do
         dup i + c@ 9 = if \ check for tab          i c@ 9 = if \ check for tab
             9              9
         else          else
             bl              bl
         then          then
         emit          emit
     loop      loop
     drop ;  ;
   
 DEFER DOERROR  DEFER DOERROR
   
   : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
     cr error-stack @
     IF
        ." in file included from "
        type ." :" dec.  drop 2drop
     ELSE
        type ." :" dec.
        cr dup 2over type cr drop
        nip -trailing 1- ( line-start index2 )
        0 >r  BEGIN
                     2dup + c@ bl >  WHILE
                     r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
        ( line-start index1 )
        typewhite
        r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                     [char] ^ emit
        loop
     THEN
   ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
     LoadFile @    loadline @ IF
     IF                 source >in @ loadline @ 0 0 .error-frame
         cr loadfilename 2@ type ." :" Loadline @ dec.    THEN
     THEN    error-stack @ 0 ?DO
     cr source type cr      -1 error-stack +!
     source drop >in @ -trailing ( throw-code line-start index2 )      error-stack dup @ 6 * cells + cell+
     here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )      6 cells bounds DO
     typewhite        I @
     r> 1 max 0 ?do \ we want at least one "^", even if the length is 0      cell +LOOP
         ." ^"      .error-frame
     loop    LOOP
     dup -2 =    dup -2 =
     IF     IF 
         "error @ ?dup       "error @ ?dup
         IF       IF
             cr count type           cr count type 
         THEN       THEN
         drop       drop
     ELSE    ELSE
         .error       .error
     THEN    THEN
     normal-dp dpp ! ;    normal-dp dpp ! ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
Line 1255  DEFER DOERROR Line 1350  DEFER DOERROR
 \ : words  listwords @  \ : words  listwords @
 \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;  \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
   
 : >len  ( cstring -- addr n )  100 0 scan 0 swap 100 - /string ;  : cstring>sstring  ( cstring -- addr n )  -1 0 scan 0 swap 1+ /string ;
 : arg ( n -- addr count )  cells argv @ + @ >len ;  : arg ( n -- addr count )  cells argv @ + @ cstring>sstring ;
 : #!       postpone \ ;  immediate  : #!       postpone \ ;  immediate
   
 Variable env  Create pathstring 2 cells allot \ string
   Create pathdirs   2 cells allot \ dir string array, pointer and count
 Variable argv  Variable argv
 Variable argc  Variable argc
   
 0 Value script? ( -- flag )  0 Value script? ( -- flag )
   
 : ">tib  ( addr len -- )  dup #tib ! >in off tib swap move ;  : process-path ( addr1 u1 -- addr2 u2 )
       \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
       here >r
       BEGIN
           over >r [char] : scan
           over r> tuck - ( rest-str this-str )
           dup
           IF
               2dup 1- chars + c@ [char] / <>
               IF
                   2dup chars + [char] / swap c!
                   1+
               THEN
               2,
           ELSE
               2drop
           THEN
           dup
       WHILE
           1 /string
       REPEAT
       2drop
       here r> tuck - 2 cells / ;
   
 : do-option ( addr1 len1 addr2 len2 -- n )  2swap  : do-option ( addr1 len1 addr2 len2 -- n )  2swap
   2dup s" -e"        compare  0= >r    2dup s" -e"        compare  0= >r
   2dup s" -evaluate" compare  0= r> or    2dup s" -evaluate" compare  0= r> or
   IF  2drop ">tib interpret  2 EXIT  THEN    IF  2drop dup >r ['] evaluate catch
         ?dup IF  dup >r DoError r> negate (bye)  THEN
         r> >tib +!  2 EXIT  THEN
   ." Unknown option: " type cr 2drop 1 ;    ." Unknown option: " type cr 2drop 1 ;
   
 : process-args ( -- )  argc @ 1  : process-args ( -- )  >tib @ >r
   ?DO  I arg over c@ [char] - <>      argc @ 1
        IF    true to script? included  false to script? 1      ?DO
        ELSE  I 1+ arg  do-option          I arg over c@ [char] - <>
        THEN          IF
   +LOOP ;              true to script? included  false to script? 1
           ELSE
               I 1+ arg  do-option
           THEN
       +LOOP
       r> >tib ! ;
   
   Defer 'cold ' noop IS 'cold
   
 : cold ( -- )    : cold ( -- )
       pathstring 2@ process-path pathdirs 2!
       'cold
     argc @ 1 >      argc @ 1 >
     IF      IF
         ['] process-args catch ?dup          ['] process-args catch ?dup
Line 1309  Variable argc Line 1438  Variable argc
  ." along with this program; if not, write to the Free Software" cr   ." along with this program; if not, write to the Free Software" cr
  ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;   ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
   
 : boot ( **env **argv argc -- )  : boot ( path **argv argc -- )
   argc ! argv ! env !  main-task up!    argc ! argv ! cstring>sstring pathstring 2!  main-task up!
   sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;    sp@ dup s0 ! $10 + >tib ! #tib off >in off
     rp@ r0 !  fp@ f0 !  cold ;
   
 : bye  script? 0= IF  cr  THEN  0 (bye) ;  : bye  script? 0= IF  cr  THEN  0 (bye) ;
   
Removed from v.1.15  
changed lines
  Added in v.1.25

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