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

version 1.57, 1996/05/07 16:15:22 version 1.61, 1996/08/21 14:58:42
Line 74  HEX Line 74  HEX
\ the code address of a @code{field}      \ the code address of a @code{field}

NIL AConstant NIL \ gforth

\ Bit string manipulation                              06oct92py  \ Bit string manipulation                              06oct92py

\ Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,  \ Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
Line 143  HEX Line 145  HEX
: off ( addr -- ) \ gforth  : off ( addr -- ) \ gforth
false swap ! ;      false swap ! ;

\ dabs roll                                           17may93jaw

: dabs ( d1 -- d2 ) \ double
dup 0< IF dnegate THEN ;

: roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
dup 1+ pick >r
cells sp@ cell+ dup cell+ rot move drop r> ;

\ name> found                                          17dec92py  \ name> found                                          17dec92py

: (name>)  ( nfa+cell -- cfa )  \$80 constant alias-mask \ set when the word is not an alias!
1 cells - name>string +  cfaligned ;  \$40 constant immediate-mask
: name>    ( nfa -- cfa ) \ gforth  \$20 constant restrict-mask
cell+
dup  (name>) swap  c@ \$80 and 0= IF  @ THEN ;  : ((name>))  ( nfa -- cfa )
name>string +  cfaligned ;
: found ( nfa -- cfa n ) \ gforth
cell+  : (name>x) ( nfa -- cfa b )
dup c@ >r  (name>) r@ \$80 and  0= IF  @       THEN      \ cfa is an intermediate cfa and b is the flags byte of nfa
-1 r@ \$40 and     IF  1-      THEN      dup ((name>))
r> \$20 and     IF  negate  THEN  ;      swap cell+ c@ dup alias-mask and 0=
IF
\ (find)                                               17dec92py          swap @ swap
THEN ;
\ : (find) ( addr count nfa1 -- nfa2 / false )
\   BEGIN  dup  WHILE  dup >r
\          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 173  HEX Line 178  HEX
: bounds ( beg count -- end beg ) \ gforth  : bounds ( beg count -- end beg ) \ gforth
over + swap ;      over + swap ;

\ copy a memory block into a newly allocated region in the heap
swap >r
dup allocate throw
swap 2dup r> -rot move ;

\ 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 247  Defer source ( -- addr count ) \ core Line 264  Defer source ( -- addr count ) \ core
\ Literal                                              17dec92py  \ Literal                                              17dec92py

: Literal  ( compilation n -- ; run-time -- n ) \ core  : Literal  ( compilation n -- ; run-time -- n ) \ core
state @ IF postpone lit  , THEN ; immediate      postpone lit  , ; immediate restrict
: ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth  : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
state @ IF postpone lit A, THEN ;      postpone lit A, ; immediate restrict
immediate

: char   ( 'char' -- n ) \ core  : char   ( 'char' -- n ) \ core
bl word char+ c@ ;      bl word char+ c@ ;
: [char] ( compilation 'char' -- ; run-time -- n )  : [char] ( compilation 'char' -- ; run-time -- n )
char postpone Literal ; immediate      char postpone Literal ; immediate restrict
' [char] Alias Ascii immediate

: (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 "  \ not the most efficient implementation of POSTPONE, but simple
0> IF  compile,  ELSE  postpone (compile) A,  THEN ;  : POSTPONE ( -- ) \ core
immediate restrict      COMP' swap POSTPONE aliteral compile, ; immediate restrict

: interpret/compile: ( interp-xt comp-xt "name" -- )
Create immediate swap A, A,
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 486  Defer parser Line 507  Defer parser
Defer name ( -- c-addr count ) \ gforth  Defer name ( -- c-addr count ) \ gforth
\ get the next word from the input buffer  \ get the next word from the input buffer
' (name) IS name  ' (name) IS name
Defer notfound ( c-addr count -- )  Defer compiler-notfound ( c-addr count -- )
Defer interpreter-notfound ( c-addr count -- )

: no.extensions  ( addr u -- )  : no.extensions  ( addr u -- )
2drop -&13 bounce ;      2drop -&13 bounce ;
' no.extensions IS notfound  ' no.extensions IS compiler-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 508  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> 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 notfound
THEN ;

: [ ( -- ) \ core       left-bracket  : [ ( -- ) \ core       left-bracket
['] interpreter  IS parser state off ; immediate      ['] interpreter  IS parser state off ; immediate
Line 627  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 734  variable backedge-locals Line 750  variable backedge-locals
: ?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-0=-?branch >mark ;       immediate restrict      POSTPONE ?dup-0=-?branch >mark ;       immediate restrict

: THEN ( compilation orig -- ; run-time -- ) \ core  : then-like ( orig -- addr )
dup orig?      swap -rot dead-orig =
if      if
>resolve drop          drop
else      else
if          if
else \ both live          else \ both live
>resolve
locals-list @ common-list dup list-size adjust-locals-size              locals-list @ common-list dup list-size adjust-locals-size
locals-list !              locals-list !
then          then
then ; immediate restrict      then ;

: THEN ( compilation orig -- ; run-time -- ) \ core
dup orig?  then-like  >resolve ; immediate restrict

' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth  ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
immediate restrict  immediate restrict
Line 778  immediate restrict Line 795  immediate restrict
\ issue a warning (see below). The following code is generated:  \ issue a warning (see below). The following code is generated:
\ lp+!# (current-local-size - dest-locals-size)  \ lp+!# (current-local-size - dest-locals-size)
\ branch <begin>  \ branch <begin>
: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
dest?  : again-like ( dest -- addr )
POSTPONE branch      swap check-begin  POSTPONE unreachable ;
<resolve
check-begin  : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
POSTPONE unreachable ; immediate restrict      dest? again-like  POSTPONE branch  <resolve ; 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 951  Avariable leave-sp  leave-stack 3 cells Line 968  Avariable leave-sp  leave-stack 3 cells
: 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
create s"-buffer /line chars allot
: S" ( compilation 'ccc"' -- ; run-time -- c-addr u )   \ core,file     s-quote
[char] " parse
state @
IF
postpone SLiteral
ELSE
/line min >r s"-buffer r@ cmove
s"-buffer r>
THEN ; immediate

: ." ( compilation 'ccc"' -- ; run-time -- )  \ core    dot-quote
state @  IF    postpone (.") ,"  align
ELSE  [char] " parse type  THEN  ;  immediate
: ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren
BEGIN      BEGIN
>in @ [char] ) parse nip >in @ rot - =          >in @ [char] ) parse nip >in @ rot - =
Line 998  create s"-buffer /line chars allot Line 1001  create s"-buffer /line chars allot

: flag! ( 8b -- )  : cset ( bmask c-addr -- )
last @ dup 0= abort" last word was headerless"      tuck c@ or swap c! ;
cell+ tuck c@ xor swap c! ;  : creset ( bmask c-addr -- )
: immediate     \$20 flag! ;      tuck c@ swap invert and swap c! ;
: restrict      \$40 flag! ;  : ctoggle ( bmask c-addr -- )
\ ' noop alias restrict      tuck c@ xor swap c! ;

: lastflags ( -- c-addr )
\ aborts if the last defined word was headerless
last @ dup 0= abort" last word was headerless" cell+ ;

: immediate     immediate-mask lastflags cset ;
: restrict      restrict-mask lastflags cset ;

Line 1019  defer header ( -- ) \ gforth Line 1030  defer header ( -- ) \ gforth
\ puts down string as cstring      \ puts down string as cstring
dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;

: name,  ( "name" -- ) \ gforth  : header, ( c-addr u -- ) \ gforth
name name-too-short? name-too-long?      name-too-long?
string, cfalign ;      align here last !
: input-stream-header ( "name" -- )      current @ 1 or A,   \ link field; before revealing, it contains the
\ !! this is f83-implementation-dependent                          \ tagged reveal-into wordlist
align here last !  -1 A,      string, cfalign
name, \$80 flag! ;      alias-mask lastflags cset ;

: input-stream-header ( "name" -- )
: 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 ;
Line 1037  defer header ( -- ) \ gforth Line 1050  defer header ( -- ) \ gforth
create nextname-buffer 32 chars allot  create nextname-buffer 32 chars allot

\ !! f83-implementation-dependent      nextname-buffer count header,
nextname-buffer count
align here last ! -1 A,
string, cfalign
\$80 flag!
input-stream ;      input-stream ;

\ the next name is given in the string  \ the next name is given in the string
Line 1064  create nextname-buffer 32 chars allot Line 1073  create nextname-buffer 32 chars allot
lastcfa @ ;      lastcfa @ ;

: Alias    ( cfa "name" -- ) \ gforth  : Alias    ( cfa "name" -- ) \ gforth
dup A, lastcfa ! ;

: name>string ( nfa -- addr count ) \ gforth    name-to-string  : name>string ( nfa -- addr count ) \ gforth    name-to-string
cell+ count \$1F and ;   cell+ count \$1F and ;
Line 1072  create nextname-buffer 32 chars allot Line 1083  create nextname-buffer 32 chars allot
Create ???  0 , 3 c, char ? c, char ? c, char ? c,  Create ???  0 , 3 c, char ? c, char ? c, char ? c,
: >name ( cfa -- nfa ) \ gforth to-name  : >name ( cfa -- nfa ) \ gforth to-name
\$21 cell do   \$21 cell do
dup i - count \$9F and + cfaligned over \$80 + = if     dup i - count \$9F and + cfaligned over alias-mask + = if
i - cell - unloop exit       i - cell - unloop exit
then     then
cell +loop   cell +loop
Line 1096  Create ???  0 , 3 c, char ? c, char ? c, Line 1107  Create ???  0 , 3 c, char ? c, char ? c,
: Create ( -- ) \ core  : Create ( -- ) \ core

\ DOES>                                                17mar93py

: DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does
state @
IF
;-hook postpone (does>) ?struc dodoes,
ELSE
align dodoes, here !does ]
THEN
defstart :-hook ; immediate

\ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py

: Variable ( -- ) \ core  : Variable ( -- ) \ core
Line 1144  Create ???  0 , 3 c, char ? c, char ? c, Line 1144  Create ???  0 , 3 c, char ? c, char ? c,
\     DOES> ( ??? )  \     DOES> ( ??? )
\       perform ;  \       perform ;

: IS ( addr "name" -- ) \ gforth
' >body
state @
IF    postpone ALiteral postpone !
ELSE  !
THEN ;  immediate
' IS Alias TO ( addr "name" -- ) \ core-ext
immediate

: What's ( "name" -- addr ) \ gforth
' >body
state @
IF
postpone ALiteral postpone @
ELSE
@
THEN ; immediate
: Defers ( "name" -- ) \ gforth  : Defers ( "name" -- ) \ gforth
' >body @ compile, ; immediate      ' >body @ compile, ; immediate

Line 1184  AVariable current ( -- addr ) \ gforth Line 1167  AVariable current ( -- addr ) \ gforth

: last?   ( -- false / nfa nfa )  : last?   ( -- false / nfa nfa )
last @ ?dup ;      last @ ?dup ;
: (reveal) ( -- )  : (reveal) ( nfa wid -- )
last?      ( wid>wordlist-id ) dup >r
IF      @ over ( name>link ) !
dup @ 0<      r> ! ;
IF
current @ @ over ! current @ !
ELSE
drop
THEN
THEN ;

\ object oriented search list                          17mar93py  \ object oriented search list                          17mar93py

Line 1201  AVariable current ( -- addr ) \ gforth Line 1178  AVariable current ( -- addr ) \ gforth

struct  struct
1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )    1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field    1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field
1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field rehash-method \ xt: ( wid -- )
\   \ !! what else  \   \ !! what else
end-struct wordlist-map-struct  end-struct wordlist-map-struct
Line 1213  struct Line 1190  struct
1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)    1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
end-struct wordlist-struct  end-struct wordlist-struct

: f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;  : f83find      ( addr len wordlist -- nfa / false )
( wid>wordlist-id ) @ (f83find) ;

\ Search list table: find reveal  \ Search list table: find reveal
Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,  Create f83search ( -- wordlist-map )
' 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 lookup       G forth-wordlist lookup T !  AVariable lookup       G forth-wordlist lookup T !
G forth-wordlist current T !  G forth-wordlist current T !

\ higher level parts of find

( struct )
0 >body cell
1 cells: field special-interpretation
1 cells: field special-compilation
end-struct special-struct

: interpret/compile? ( xt -- flag )
>does-code ['] S" >does-code = ;

: (x>int) ( cfa b -- xt )
\ get interpretation semantics of name
if
drop ['] compile-only-error
else
dup interpret/compile?
if
special-interpretation @
then
then ;

: name>int ( nfa -- xt ) \ gforth
(name>x) (x>int) ;

: name>comp ( nfa -- w xt ) \ gforth
\ get compilation semantics of name
(name>x) >r dup interpret/compile?
if
special-compilation @
then
['] 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 ;

: flag-sign ( f -- 1|-1 )
\ 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 )
then ;

: search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search  : find-name ( c-addr u -- nfa/0 )
(search-wordlist) dup  IF  found  THEN ;      lookup @ (search-wordlist) ;

: sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
find-name dup
if ( nfa )
state @
if
name>comp ['] execute =
else
(name>x) tuck (x>int)
then
flag-sign
then ;

: find ( c-addr -- xt +-1 / c-addr 0 ) \ core
dup count sfind dup
if
rot drop
then ;

: (') ( "name" -- nfa ) \ gforth
name find-name dup 0=
IF
drop -&13 bounce
THEN  ;

: [(')]  ( compilation "name" -- ; run-time -- nfa ) \ gforth   bracket-paren-tick
(') postpone ALiteral ; immediate restrict

: '    ( "name" -- xt ) \ core  tick
(') name>int ;
: [']  ( compilation "name" -- ; run-time -- xt ) \ core        bracket-tick
' postpone ALiteral ; immediate restrict

: COMP'    ( "name" -- w xt ) \ gforth  c-tick
(') name>comp ;
: [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth        bracket-comp-tick
COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict

\ reveal words

Variable warnings ( -- addr ) \ gforth  Variable warnings ( -- addr ) \ gforth
G -1 warnings T !  G -1 warnings T !

\ prints a warning if the string is already present in the wordlist  \ prints a warning if the string is already present in the wordlist
\ !! should be refined so the user can suppress the warnings
>r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if   >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
." redefined " name>string 2dup type     ." redefined " name>string 2dup type
compare 0<> if     compare 0<> if
Line 1245  G -1 warnings T ! Line 1312  G -1 warnings T !
then   then
2drop 2drop ;   2drop 2drop ;

: sfind ( c-addr u -- xt n / 0 ) \ gforth
lookup @ search-wordlist ;

: find   ( addr -- cfa +-1 / string false ) \ core,search
\ !! not ANS conformant: returns +-2 for restricted words
dup count sfind dup if
rot drop
then ;

: reveal ( -- ) \ gforth  : reveal ( -- ) \ gforth
last? if      last?
name>string current @ check-shadow      if \ the last word has a header
then          dup ( name>link ) @ 1 and
current @ wordlist-map @ reveal-method perform ;          if \ it is still hidden
dup ( name>link ) @ 1 xor           ( nfa wid )
2dup >r name>string r> check-shadow ( nfa wid )
dup wordlist-map @ reveal-method perform
then
then ;

: rehash  ( wid -- )  : rehash  ( wid -- )
dup wordlist-map @ rehash-method perform ;      dup wordlist-map @ rehash-method perform ;

: '    ( "name" -- addr ) \ core        tick
name sfind 0= if -&13 bounce then ;
: [']  ( compilation "name" -- ; run-time --addr ) \ core       bracket-tick
' postpone ALiteral ; immediate
\ Input                                                13feb93py  \ Input                                                13feb93py

07 constant #bell ( -- c ) \ gforth  07 constant #bell ( -- c ) \ gforth
Line 1285  G -1 warnings T ! Line 1344  G -1 warnings T !

\ : backspaces  0 ?DO  #bs emit  LOOP ;  \ : backspaces  0 ?DO  #bs emit  LOOP ;

Variable ^d-mode  -1 ^d-mode ! \ ^d is "EOF" if at beginning of the line  : (ins) ( max span addr pos1 key -- max span addr pos2 )
>r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
over 3 pick 2 pick chars /string ;      dup IF
: type-rest ( span addr pos1 -- span addr pos1 back )          #bs emit bl emit #bs emit 1- rot 1- -rot
>string tuck type ;      THEN false ;
: (del)  ( max span addr pos1 -- max span addr pos2 )  : (ret)  true space ;
1- >string over 1+ -rot move
rot 1- -rot  #bs emit  type-rest bl emit 1+ backspaces ;
: (ins)  ( max span addr pos1 char -- max span addr pos2 )
>r >string over 1+ swap move 2dup chars + r> swap c!
rot 1+ -rot type-rest 1- backspaces 1+ ;
: ?del ( max span addr pos1 -- max span addr pos2 0 )
dup  IF  (del)  THEN  0 ;
: (ret)  type-rest drop true space ;
: 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 ;
: eof  ^d-mode @  IF
bye
ELSE  2 pick over <>
IF  forw drop (del)  ELSE  #bell emit  THEN  0
THEN ;

Create ctrlkeys  Create ctrlkeys
] false false back  false  eof   false forw  false    ] false false false false  false false false false
?del  false (ret) false  false (ret) false false      (bs)  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 insert-char
' (ins) IS insert-char
defer everychar  defer everychar
' noop IS everychar  ' noop IS everychar

Line 1322  defer everychar Line 1368  defer everychar
dup #del = IF  drop #bs  THEN  \ del is rubout    dup #del = IF  drop #bs  THEN  \ del is rubout
dup bl <   IF  cells ctrlkeys + perform  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> insert-char 0 ;

: accept   ( addr len -- len ) \ core  : accept   ( addr len -- len ) \ core
dup 0< IF    abs over dup 1 chars - c@ tuck type     dup 0< IF    abs over dup 1 chars - c@ tuck type
\ this allows to edit given strings  \ this allows to edit given strings
ELSE  0  THEN rot over           ELSE  0  THEN rot over
BEGIN  key decode dup ^d-mode !  UNTIL    BEGIN  key decode  UNTIL
2drop nip ;    2drop nip ;

\ Output                                               13feb93py  \ Output                                               13feb93py
Line 1445  create pathfilenamebuf 256 chars allot \ Line 1491  create pathfilenamebuf 256 chars allot \
\   ELSE   false  \   ELSE   false
\   THEN ;  \   THEN ;

: absolut-path? ( addr u -- flag ) \ gforth
\ a path is absolute, if it starts with a / or a ~ (~ expansion),
\ or if it is in the form ./* or ../*, extended regexp: [/~]|./|../
\ Pathes simply containing a / are not absolute!
over c@ '/ = >r
over c@ '~ = >r
2dup 2 min S" ./" compare 0= >r
3 min S" ../" compare 0=
r> r> r> or or or ;
\   [char] / scan nip 0<> ;

: open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth  : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth
\ opens a file for reading, searching in the path for it (unless      \ opens a file for reading, searching in the path for it (unless
\ the filename contains a slash); c-addr2 u2 is the full filename      \ the filename contains a slash); c-addr2 u2 is the full filename
Line 1454  create pathfilenamebuf 256 chars allot \ Line 1511  create pathfilenamebuf 256 chars allot \
\ the path will usually contain dirs that are only readable for      \ the path will usually contain dirs that are only readable for
\ the user      \ the user
\ !! use file-status to determine access mode?      \ !! use file-status to determine access mode?
2dup [char] / scan nip ( 0<> )      2dup absolut-path?
if \ the filename contains a slash      if \ the filename contains a slash
2dup r/o open-file throw ( c-addr1 u1 file-id )          2dup r/o open-file throw ( c-addr1 u1 file-id )
-rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )          -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
Line 1501  create image-included-files  1 , A, ( po Line 1558  create image-included-files  1 , A, ( po

: 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 1519  create image-included-files  1 , A, ( po Line 1576  create image-included-files  1 , A, ( po

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
included-files 2@ nip 1- loadfilename# !      included-files 2@ nip 1- loadfilename# !
['] include-file catch      ['] include-file catch
Line 1583  create image-included-files  1 , A, ( po Line 1637  create image-included-files  1 , A, ( po

: recurse ( compilation -- ; run-time ?? -- ?? ) \ core  : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
lastxt compile, ; immediate restrict      lastxt compile, ; immediate restrict
: recursive ( -- ) \ gforth  ' reveal alias recursive ( -- ) \ gforth
reveal last off ; immediate          immediate

\ */MOD */                                              17may93jaw  \ */MOD */                                              17may93jaw

Line 1632  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
Line 1818  Defer 'cold ' noop IS 'cold Line 1876  Defer 'cold ' noop IS 'cold
\ or space and stackspace overrides  \ or space and stackspace overrides

\ 0 arg contains, however, the name of the program.  \ 0 arg contains, however, the name of the program.

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

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