--- gforth/extend.fs 1994/08/31 19:42:45 1.6 +++ gforth/extend.fs 1997/01/04 16:32:28 1.19 @@ -1,62 +1,89 @@ \ EXTEND.FS CORE-EXT Word not fully tested! 12may93jaw +\ Copyright (C) 1995 Free Software Foundation, Inc. + +\ This file is part of Gforth. + +\ Gforth is free software; you can redistribute it and/or +\ modify it under the terms of the GNU General Public License +\ as published by the Free Software Foundation; either version 2 +\ of the License, or (at your option) any later version. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +\ GNU General Public License for more details. + +\ You should have received a copy of the GNU General Public License +\ along with this program; if not, write to the Free Software +\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + \ May be cross-compiled decimal \ .( 12may93jaw -: .( [char] ) parse type ; +: .( ( compilation "..." -- ) \ core-ext dot-paren + [char] ) parse type ; immediate \ VALUE 2>R 2R> 2R@ 17may93jaw -: value ( n -- ) +: value ( w "name" -- ) \ core-ext (constant) , ; \ !! 2value -: 2Literal swap postpone Literal postpone Literal ; - immediate restrict +: 2Literal ( compilation w1 w2 -- ; run-time -- w1 w2 ) \ double two-literal + swap postpone Literal postpone Literal ; immediate restrict -: m*/ ( d1 n2 u3 -- dqout ) >r s>d >r abs -rot - s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um* - swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap - r> IF dnegate THEN ; +' drop alias d>s ( d -- n ) \ double d_to_s + +: m*/ ( d1 n2 u3 -- dqout ) \ double m-star-slash + >r s>d >r abs -rot + s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um* + swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap + r> IF dnegate THEN ; \ CASE OF ENDOF ENDCASE 17may93jaw \ just as described in dpANS5 -0 CONSTANT case immediate +0 CONSTANT case ( compilation -- case-sys ; run-time -- ) \ core-ext + immediate -: of - 1+ >r - postpone over postpone = postpone if postpone drop - r> ; immediate - -: endof - >r postpone else r> ; immediate - -: endcase - postpone drop - 0 ?do postpone then loop ; immediate +: of ( compilation -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext + \ !! the implementation does not match the stack effect + 1+ >r + postpone over postpone = postpone if postpone drop + r> ; immediate + +: endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time -- ) \ core-ext end-of + >r postpone else r> ; immediate + +: endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case + postpone drop + 0 ?do postpone then loop ; immediate \ C" 17may93jaw : (c") "lit ; -: CLiteral postpone (c") here over char+ allot place align ; - immediate restrict -: C" [char] " parse postpone CLiteral ; immediate restrict +: CLiteral + postpone (c") here over char+ allot place align ; immediate restrict + +: C" ( compilation "..." -- ; run-time -- c-addr ) \ core-ext c-quote + [char] " parse postpone CLiteral ; immediate restrict \ UNUSED 17may93jaw -: unused s0 @ 512 - \ for stack - here - ; +: unused ( -- u ) \ core-ext + forthstart dup 3 cells + @ + here - ; \ [COMPILE] 17may93jaw -: [compile] - ' compile, ; immediate +: [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile + ' compile, ; immediate \ MARKER 17may93jaw @@ -65,40 +92,91 @@ decimal \ CONVERT 17may93jaw -: convert true >number drop ; +: convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext + \ obsolescent; superseded by @code{>number}. + true >number drop ; \ ERASE 17may93jaw -: erase ( 0 1 chars um/mod nip ) 0 fill ; -: blank ( 0 1 chars um/mod nip ) bl fill ; - -\ ROLL 17may93jaw - -: roll dup 1+ pick >r - cells sp@ cell+ dup cell+ rot move drop r> ; +: erase ( addr len -- ) \ core-ext + \ !! dependence on "1 chars 1 =" + ( 0 1 chars um/mod nip ) 0 fill ; +: blank ( addr len -- ) \ string + bl fill ; + +\ SEARCH 02sep94py + +: search ( buf buflen text textlen -- restbuf restlen flag ) \ string + 2over 2 pick - 1+ 3 pick c@ >r + BEGIN + r@ scan dup + WHILE + >r >r 2dup r@ -text + 0= + IF + >r drop 2drop r> r> r> rot + 1- rdrop true + EXIT + THEN + r> r> 1 /string + REPEAT + 2drop 2drop rdrop false ; \ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw -: source-id ( -- 0 | -1 | fileid ) - loadfile @ dup 0= IF drop loadline @ 0 min THEN ; +: source-id ( -- 0 | -1 | fileid ) \ core-ext source-i-d + loadfile @ dup 0= IF drop sourceline# 0 min THEN ; -: save-input ( -- x1 .. xn n ) - >in @ - loadfile @ ?dup - IF dup file-position throw loadline @ >tib @ 6 - #tib @ >tib +! - ELSE loadline @ blk @ linestart @ >tib @ 5 THEN -; - -: restore-input ( x1 .. xn n -- flag ) - swap >tib ! - 6 = IF loadline ! rot dup loadfile ! - reposition-file IF drop true EXIT THEN - ELSE linestart ! blk ! - dup loadline @ <> IF 2drop true EXIT THEN - loadline ! - THEN - >in ! false ; +: save-input ( -- x1 .. xn n ) \ core-ext + >in @ + loadfile @ + if + loadfile @ file-position throw + else + blk @ + linestart @ + then + sourceline# + >tib @ + source-id + 6 ; + +: restore-input ( x1 .. xn n -- flag ) \ core-ext + 6 <> -12 and throw + source-id <> -12 and throw + >tib ! + >r ( line# ) + loadfile @ 0<> + if + loadfile @ reposition-file throw + else + linestart ! + blk ! + sourceline# r@ <> blk @ 0= and loadfile @ 0= and + if + drop rdrop true EXIT + then + then + r> loadline ! + >in ! + false ; + +\ : save-input ( -- x1 .. xn n ) \ core-ext +\ >in @ +\ loadfile @ ?dup +\ IF dup file-position throw sourceline# >tib @ 6 +\ #tib @ >tib +! +\ ELSE sourceline# blk @ linestart @ >tib @ 5 THEN +\ ; + +\ : restore-input ( x1 .. xn n -- flag ) \ core-ext +\ swap >tib ! +\ 6 = IF loadline ! rot dup loadfile ! +\ reposition-file IF drop true EXIT THEN +\ ELSE linestart ! blk ! +\ dup sourceline# <> IF 2drop true EXIT THEN +\ loadline ! +\ THEN +\ >in ! false ; @@ -106,10 +184,16 @@ decimal \ EXPECT SPAN 17may93jaw -variable span +variable span ( -- a-addr ) \ core-ext +\ obsolescent -: expect ( c-addr +len -- ) - 0 rot over - BEGIN key decode >r 2over = r> or UNTIL - 2drop nip span ! ; +: expect ( c-addr +len -- ) \ core-ext + \ obsolescent; use accept + 0 rot over + BEGIN ( maxlen span c-addr pos1 ) + key decode ( maxlen span c-addr pos2 flag ) + >r 2over = r> or + UNTIL + 2 pick swap /string type + nip span ! ;