Diff for /gforth/Attic/kernal.fs between versions 1.10 and 1.20

version 1.10, 1994/07/08 15:00:51 version 1.20, 1994/09/12 19:00:32
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 )
 : (cname) ( -- addr )  bl word capitalize ;      source 2dup >r >r >in @ /string (parse-white)
       2dup + r> - 1+ r> min >in ! ;
   \    name count ;
   
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
Line 157  Defer source Line 175  Defer source
   
 : (compile) ( -- )  r> dup cell+ >r @ A, ;  : (compile) ( -- )  r> dup cell+ >r @ A, ;
 : 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  A,  ELSE  postpone (compile) A,  THEN ;
                                              immediate restrict                                               immediate restrict
   
Line 194  Create bases   10 ,   2 ,   A , 100 , Line 212  Create bases   10 ,   2 ,   A , 100 ,
 \ !! this saving and restoring base is an abomination! - anton  \ !! this saving and restoring base is an abomination! - anton
 : getbase ( addr u -- addr' u' )  over c@ [char] $ - dup 4 u<  : getbase ( addr u -- addr' u' )  over c@ [char] $ - dup 4 u<
   IF  cells bases + @ base ! 1 /string  ELSE  drop  THEN ;    IF  cells bases + @ base ! 1 /string  ELSE  drop  THEN ;
 : number?  ( string -- string 0 / n -1 )  base @ >r  : s>number ( addr len -- d )  base @ >r  dpl on
   dup count over c@ [char] - = dup >r  IF 1 /string  THEN    over c@ '- =  dup >r  IF  1 /string  THEN
   getbase  dpl on  0 0 2swap    getbase  dpl on  0 0 2swap
   BEGIN  dup >r >number dup  WHILE  dup r> -  WHILE    BEGIN  dup >r >number dup  WHILE  dup r> -  WHILE
          dup dpl ! over c@ [char] . =  WHILE           dup dpl ! over c@ [char] . =  WHILE
          1 /string           1 /string
   REPEAT  THEN  2drop 2drop rdrop false r> base ! EXIT  THEN    REPEAT  THEN  2drop rdrop dpl off  ELSE
   2drop rot drop rdrop r> IF dnegate THEN    2drop rdrop r> IF  dnegate  THEN
   dpl @ dup 0< IF  nip  THEN  r> base ! ;    THEN r> base ! ;
   : snumber? ( c-addr u -- 0 / n -1 / d 0> )
       s>number dpl @ 0=
       IF
           2drop false  EXIT
       THEN
       dpl @ dup 0> 0= IF
           nip
       THEN ;
   : number? ( string -- string 0 / n -1 / d 0> )
       dup >r count snumber? dup if
           rdrop
       else
           r> swap
       then ;
 : s>d ( n -- d ) dup 0< ;  : s>d ( n -- d ) dup 0< ;
 : number ( string -- d )  : number ( string -- d )
   number? ?dup 0= abort" ?"  0< IF s>d THEN ;    number? ?dup 0= abort" ?"  0< IF s>d THEN ;
Line 301  hex Line 333  hex
   
 Defer parser  Defer parser
 Defer name      ' (name) IS name  Defer name      ' (name) IS name
 Defer notfound  Defer notfound ( c-addr count -- )
   
 : no.extensions  ( string -- )  IF  &-13 bounce  THEN ;  : no.extensions  ( addr u -- )  2drop -&13 bounce ;
   
 ' no.extensions IS notfound  ' no.extensions IS notfound
   
 : interpret  : interpret
   BEGIN  ?stack name dup c@  WHILE  parser  REPEAT drop ;      BEGIN
           ?stack name dup
       WHILE
           parser
       REPEAT
       2drop ;
   
 \ interpreter compiler                                 30apr92py  \ interpreter compiler                                 30apr92py
   
 : interpreter  ( name -- ) find ?dup  : interpreter  ( c-addr u -- ) 
   IF  1 and  IF execute  EXIT THEN  -&14 throw  THEN      \ interpretation semantics for the name/number c-addr u
   number? 0= IF  notfound THEN ;      2dup sfind dup
       IF
           1 and
           IF \ not restricted to compile state?
               nip nip execute  EXIT
           THEN
           -&14 throw
       THEN
       drop
       2dup 2>r snumber?
       IF
           2rdrop
       ELSE
           2r> notfound
       THEN ;
   
 ' interpreter  IS  parser  ' interpreter  IS  parser
   
 : compiler     ( name -- ) find  ?dup  : compiler     ( c-addr u -- )
   IF  0> IF  execute EXIT THEN compile, EXIT THEN number? dup      \ compilation semantics for the name/number c-addr u
   IF  0> IF  swap postpone Literal  THEN  postpone Literal      2dup sfind dup
   ELSE  drop notfound  THEN ;      IF
           0>
           IF
               nip nip execute EXIT
           THEN
           compile, 2drop EXIT
       THEN
       drop
       2dup snumber? dup
       IF
           0>
           IF
               swap postpone Literal
           THEN
           postpone Literal
           2drop
       ELSE
           drop notfound
       THEN ;
   
 : [     ['] interpreter  IS parser state off ; immediate  : [     ['] interpreter  IS parser state off ; immediate
 : ]     ['] compiler     IS parser state on  ;  : ]     ['] compiler     IS parser state on  ;
Line 331  Defer notfound Line 400  Defer notfound
 : 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 385  variable dead-code \ true if normal code Line 454  variable dead-code \ true if normal code
    over 0<>     over 0<>
  while   while
    over     over
    cell+ name> >body @ max     name> >body @ max
    swap @ swap ( get next )     swap @ swap ( get next )
  repeat   repeat
  faligned nip ;   faligned nip ;
Line 486  variable dead-code \ true if normal code Line 555  variable dead-code \ true if normal code
 \ This is the preferred alternative to the idiom "?DUP IF", since it can be  \ This is the preferred alternative to the idiom "?DUP IF", since it can be
 \ better handled by tools like stack checkers  \ better handled by tools like stack checkers
     POSTPONE ?dup POSTPONE if ;       immediate restrict      POSTPONE ?dup POSTPONE if ;       immediate restrict
 : ?DUP-NOT-IF \ general  : ?DUP-0=-IF \ general
     POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict      POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict
   
 : 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 702  Avariable leave-sp  leave-stack 3 cells Line 766  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 726  Avariable leave-sp  leave-stack 3 cells Line 791  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 739  defer header Line 805  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 756  create nextname-buffer 32 chars allot Line 822  create nextname-buffer 32 chars allot
   
 \ the next name is given in the string  \ the next name is given in the string
 : nextname ( c-addr u -- ) \ general  : nextname ( c-addr u -- ) \ general
     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 767  create nextname-buffer 32 chars allot Line 833  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 836  Create ???  0 , 3 c, char ? c, char ? c, Line 902  Create ???  0 , 3 c, char ? c, char ? c,
           
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : Defer  : Defer ( -- )
   Create ( -- )       \ !! shouldn't it be initialized with abort or something similar?
     ['] noop A,      Header Reveal [ :dodefer ] Literal cfa,
   DOES> ( ??? )      ['] noop A, ;
     @ execute ;  \     Create ( -- ) 
   \       ['] noop A,
   \     DOES> ( ??? )
   \       @ execute ;
   
 : IS ( addr "name" -- )  : IS ( addr "name" -- )
     ' >body      ' >body
Line 854  Create ???  0 , 3 c, char ? c, char ? c, Line 923  Create ???  0 , 3 c, char ? c, char ? c,
   state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;    state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;
                                              immediate                                               immediate
 : Defers ( "name" -- )  ' >body @ compile, ;  : Defers ( "name" -- )  ' >body @ compile, ;
                                              immediate restrict                                               immediate
   
 \ : ;                                                  24feb93py  \ : ;                                                  24feb93py
   
Line 903  AVariable current Line 972  AVariable current
 \ end-struct wordlist-struct  \ end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;  : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;
 : f83casefind  ( addr len wordlist -- nfa / false )  @ (f83casefind) ;  
   
 \ Search list table: find reveal  \ Search list table: find reveal
 Create f83search       ' f83casefind A,  ' (reveal) A,  ' drop A,  Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,
   
 : caps-name       ['] (cname) IS name  ['] f83find     f83search ! ;  
 : case-name       ['] (name)  IS name  ['] f83casefind f83search ! ;  
 : case-sensitive  ['] (name)  IS name  ['] f83find     f83search ! ;  
   
 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 938  Variable warnings  G -1 warnings T ! Line 1002  Variable warnings  G -1 warnings T !
  then   then
  2drop 2drop ;   2drop 2drop ;
   
 : find   ( addr -- cfa +-1 / string false )  dup  : sfind ( c-addr u -- xt n / 0 )
   count search @ search-wordlist  dup IF  rot drop  THEN ;      lookup @ search-wordlist ;
   
   : find   ( addr -- cfa +-1 / string false )
       \ !! not ANS conformant: returns +-2 for restricted words
       dup count sfind dup if
           rot drop
       then ;
   
 : reveal ( -- )  : reveal ( -- )
  last? if   last? if
Line 949  Variable warnings  G -1 warnings T ! Line 1019  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= no.extensions ;  : '    ( "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 ;
Line 1002  Create crtlkeys Line 1074  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 1022  DEFER Emit Line 1097  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  linestart @ 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 1060  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1135  create nl$ 1 c, A c, 0 c, \ gnu includes
   
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
 : include-file ( i*x fid -- j*x )  : push-file  ( -- )  r>
   linestart @ >r loadline @ >r loadfile @ >r    loadline @ >r loadfile @ >r
   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r    blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;
   
   : pop-file   ( throw-code -- throw-code )
     dup IF
            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 ;
   
   >tib +! loadfile !  : read-loop ( i*x -- j*x )
   0 loadline ! blk off    BEGIN  refill  WHILE  interpret  REPEAT ;
   BEGIN  refill  WHILE  interpret  REPEAT  
   loadfile @ close-file throw  
   
   r> >in !  r> #tib !  r> >tib ! r> blk !  : include-file ( i*x fid -- j*x )
   r> loadfile ! r> loadline ! r> linestart ! ;    push-file  loadfile !
     0 loadline ! blk off  ['] read-loop catch
     loadfile @ close-file swap 2dup or
     pop-file  drop throw throw ;
   
   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 1093  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1207  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ INCLUDE                                               9may93jaw  \ INCLUDE                                               9may93jaw
   
 : include  ( "file" -- )  : include  ( "file" -- )
   bl word count included ;    name included ;
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
Line 1104  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1218  create nl$ 1 c, A c, 0 c, \ gnu includes
   
 \ */MOD */                                              17may93jaw  \ */MOD */                                              17may93jaw
   
   \ !! I think */mod should have the same rounding behaviour as / - anton
 : */mod >r m* r> sm/rem ;  : */mod >r m* r> sm/rem ;
   
 : */ */mod nip ;  : */ */mod nip ;
Line 1111  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1226  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
 : evaluate ( c-addr len -- )  : evaluate ( c-addr len -- )
   linestart @ >r loadline @ >r loadfile @ >r    push-file  dup #tib ! >tib @ swap move
   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r    >in off blk off loadfile off -1 loadline !
   
   >tib +! dup #tib ! >tib @ swap move  \  BEGIN  interpret  >in @ #tib @ u>= UNTIL
   >in off blk off loadfile off -1 linestart !    ['] interpret catch
     pop-file throw ;
   BEGIN  interpret  >in @ #tib @ u>= UNTIL  
   
   r> >in !  r> #tib !  r> >tib ! r> blk !  
   r> loadfile ! r> loadline ! r> linestart ! ;  
   
   
 : abort -1 throw ;  : abort -1 throw ;
Line 1138  Defer .status Line 1249  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 1197  DEFER DOERROR Line 1337  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
   
 : get-args ( -- )  #tib off  0 Value script? ( -- flag )
   argc @ 1 ?DO  I arg 2dup source + swap move  
                 #tib +! drop  bl source + c! 1 #tib +!  LOOP  
   >in off #tib @ 0<> #tib +! ;  
   
 : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;  
   
 : cold ( -- )    : process-path ( addr1 u1 -- addr2 u2 )
     argc @ 1 >      \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
     IF  script?      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 / ;
   
   : ">tib  ( addr len -- )  dup #tib ! >in off tib swap move ;
   
   : do-option ( addr1 len1 addr2 len2 -- n )  2swap
     2dup s" -e"        compare  0= >r
     2dup s" -evaluate" compare  0= r> or
     IF  2drop ">tib interpret  2 EXIT  THEN
     ." Unknown option: " type cr 2drop 1 ;
   
   : process-args ( -- )
       argc @ 1
       ?DO
           I arg over c@ [char] - <>
         IF          IF
             1 arg ['] included              true to script? included  false to script? 1
         ELSE          ELSE
             get-args ['] interpret              I 1+ arg  do-option
         THEN          THEN
         catch ?dup      +LOOP ;
   
   : cold ( -- )
       pathstring 2@ process-path pathdirs 2!
       argc @ 1 >
       IF
           ['] process-args catch ?dup
         IF          IF
             dup >r DoError cr r> (bye)              dup >r DoError cr r> negate (bye)
         THEN          THEN
     THEN      THEN
     cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation"      cr
     cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'"       ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr
     cr quit ;      ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
       ." Type `bye' to exit"
       quit ;
   
   : license ( -- ) cr
    ." This program is free software; you can redistribute it and/or modify" cr
    ." it under the terms of the GNU General Public License as published by" cr
    ." the Free Software Foundation; either version 2 of the License, or" cr
    ." (at your option) any later version." cr cr
   
    ." This program is distributed in the hope that it will be useful," cr
    ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
    ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the" cr
    ." GNU General Public License for more details." cr cr
   
    ." You should have received a copy of the GNU General Public License" cr
    ." along with this program; if not, write to the Free Software" 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 ! rp@ r0 !  fp@ f0 !  cold ;
   
 : bye  cr 0 (bye) ;  : bye  script? 0= IF  cr  THEN  0 (bye) ;
   
 \ **argv may be scanned by the C starter to get some important  \ **argv may be scanned by the C starter to get some important
 \ information, as -display and -geometry for an X client FORTH  \ information, as -display and -geometry for an X client FORTH

Removed from v.1.10  
changed lines
  Added in v.1.20


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