Diff for /gforth/Attic/kernal.fs between versions 1.51 and 1.56

version 1.51, 1996/01/25 16:45:53 version 1.56, 1996/05/06 12:39:02
Line 453  hex Line 453  hex
   
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception  : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
     ?DUP IF      ?DUP IF
         [ here 4 cells ! ]          [ here 9 cells ! ]
         handler @ rp!          handler @ rp!
         r> handler !          r> handler !
         r> lp!          r> lp!
Line 492  Defer notfound ( c-addr count -- ) Line 492  Defer notfound ( c-addr count -- )
     2drop -&13 bounce ;      2drop -&13 bounce ;
 ' no.extensions IS notfound  ' no.extensions IS notfound
   
   : compile-only ( ... -- )
       -&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
     BEGIN      BEGIN
Line 511  Defer notfound ( c-addr count -- ) Line 516  Defer notfound ( c-addr count -- )
         IF \ not restricted to compile state?          IF \ not restricted to compile state?
             nip nip execute EXIT              nip nip execute EXIT
         THEN          THEN
         -&14 throw          interpret-special exit
     THEN      THEN
     drop      drop
     2dup 2>r snumber?      2dup 2>r snumber?
Line 723  variable backedge-locals Line 728  variable backedge-locals
   
 : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth   question-dupe-if  : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth   question-dupe-if
 \ 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. Besides, it's faster.
     POSTPONE ?dup POSTPONE if ;       immediate restrict      POSTPONE ?dup-?branch >mark ;       immediate restrict
   
 : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if  : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if
     POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict      POSTPONE ?dup-0=-?branch >mark ;       immediate restrict
   
 : THEN ( compilation orig -- ; run-time -- ) \ core  : THEN ( compilation orig -- ; run-time -- ) \ core
     dup orig?      dup orig?
Line 960  create s"-buffer /line chars allot Line 966  create s"-buffer /line chars allot
     state @  IF    postpone (.") ,"  align      state @  IF    postpone (.") ,"  align
                     ELSE  [char] " parse type  THEN  ;  immediate                      ELSE  [char] " parse type  THEN  ;  immediate
 : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren
     [char] ) parse 2drop ;                       immediate      BEGIN
           >in @ [char] ) parse nip >in @ rot - =
       WHILE
           loadfile @ IF
               refill 0= abort" missing ')' in paren comment"
           THEN
       REPEAT ;                       immediate
 : \ ( -- ) \ core-ext backslash  : \ ( -- ) \ core-ext backslash
     blk @      blk @
     IF      IF
Line 1130  Create ???  0 , 3 c, char ? c, char ? c, Line 1142  Create ???  0 , 3 c, char ? c, char ? c,
 \     Create ( -- )   \     Create ( -- ) 
 \       ['] noop A,  \       ['] noop A,
 \     DOES> ( ??? )  \     DOES> ( ??? )
 \       @ execute ;  \       perform ;
   
 : IS ( addr "name" -- ) \ gforth  : IS ( addr "name" -- ) \ gforth
     ' >body      ' >body
Line 1211  AVariable lookup       G forth-wordlist Line 1223  AVariable lookup       G forth-wordlist
 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 wordlist-map @ find-method @ execute ;    dup wordlist-map @ find-method perform ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search  : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search
     (search-wordlist) dup  IF  found  THEN ;      (search-wordlist) dup  IF  found  THEN ;
Line 1246  G -1 warnings T ! Line 1258  G -1 warnings T !
  last? if   last? if
    name>string current @ check-shadow     name>string current @ check-shadow
  then   then
  current @ wordlist-map @ reveal-method @ execute ;   current @ wordlist-map @ reveal-method perform ;
   
 : rehash  ( wid -- )  : rehash  ( wid -- )
     dup wordlist-map @ rehash-method @ execute ;      dup wordlist-map @ rehash-method perform ;
   
 : '    ( "name" -- addr ) \ core        tick  : '    ( "name" -- addr ) \ core        tick
     name sfind 0= if -&13 bounce then ;      name sfind 0= if -&13 bounce then ;
Line 1301  defer everychar Line 1313  defer everychar
 : decode ( max span addr pos1 key -- max span addr pos2 flag )  : decode ( max span addr pos1 key -- max span addr pos2 flag )
   everychar    everychar
   dup #del = IF  drop #bs  THEN  \ del is rubout    dup #del = IF  drop #bs  THEN  \ del is rubout
   dup bl <   IF  cells ctrlkeys + @ execute  EXIT  THEN    dup bl <   IF  cells ctrlkeys + perform  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 1317  defer everychar Line 1329  defer everychar
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
   : (type) ( c-addr u -- ) \ gforth
       outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
   ;
   
 Defer type ( c-addr u -- ) \ core  Defer type ( c-addr u -- ) \ core
 \ defer type for a output buffer or fast  \ defer type for a output buffer or fast
 \ screen write  \ screen write
   
 \ : (type) ( addr len -- )  
 \   bounds ?DO  I c@ emit  LOOP ;  
   
 ' (type) IS Type  ' (type) IS Type
   
   : (emit) ( c -- ) \ gforth
       outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
   ;
   
 Defer emit ( c -- ) \ core  Defer emit ( c -- ) \ core
 ' (Emit) IS Emit  ' (Emit) IS Emit
   
Line 1749  Variable argc Line 1766  Variable argc
 Defer 'cold ' noop IS 'cold  Defer 'cold ' noop IS 'cold
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
       stdout TO outfile-id
     pathstring 2@ process-path pathdirs 2!      pathstring 2@ process-path pathdirs 2!
     init-included-files      init-included-files
     'cold      'cold

Removed from v.1.51  
changed lines
  Added in v.1.56


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