Annotation of gforth/extend.fs, revision 1.1
1.1 ! anton 1: \ EXTEND.FS CORE-EXT Word not fully tested! 12may93jaw
! 2:
! 3: \ May be cross-compiled
! 4:
! 5: decimal
! 6:
! 7: \ .( 12may93jaw
! 8:
! 9: : .( [char] ) parse type ;
! 10:
! 11: \ VALUE 2>R 2R> 2R@ 17may93jaw
! 12:
! 13: : value ( n -- ) (constant) , ;
! 14:
! 15: : 2>r postpone >r postpone >r ; immediate restrict
! 16: : 2r> postpone r> postpone r> ; immediate restrict
! 17: : 2r@ postpone 2r> postpone 2dup postpone 2>r ; immediate restrict
! 18:
! 19: \ CASE OF ENDOF ENDCASE 17may93jaw
! 20:
! 21: \ just as described in dpANS5
! 22:
! 23: 0 CONSTANT case immediate
! 24:
! 25: : of
! 26: 1+ >r
! 27: postpone over postpone = postpone if postpone drop
! 28: r> ; immediate
! 29:
! 30: : endof
! 31: >r postpone else r> ; immediate
! 32:
! 33: : endcase
! 34: postpone drop
! 35: 0 ?do postpone then loop ; immediate
! 36:
! 37: \ C" 17may93jaw
! 38:
! 39: : (c") "lit ;
! 40:
! 41: : CLiteral postpone (c") here over char+ allot place align ;
! 42: immediate restrict
! 43: : C" [char] " parse postpone CLiteral ; immediate restrict
! 44:
! 45: \ UNUSED 17may93jaw
! 46:
! 47: : unused forthstart dup @ over 2 cells + @ -
! 48: 512 - \ for stack
! 49: + here - ;
! 50:
! 51: \ [COMPILE] 17may93jaw
! 52:
! 53: : [compile]
! 54: ' compile, ; immediate
! 55:
! 56: \ MARKER 17may93jaw
! 57:
! 58: \ : marker here last @ create , , DOES> dup @ last ! cell+ @ dp ! ;
! 59: \ doesn't work now. vocabularies?
! 60:
! 61: \ CONVERT 17may93jaw
! 62:
! 63: : convert true >number drop ;
! 64:
! 65: \ ERASE 17may93jaw
! 66:
! 67: : erase 0 1 chars um/mod nip 0 fill ;
! 68:
! 69: \ ROLL 17may93jaw
! 70:
! 71: : roll dup 1+ pick >r
! 72: cells sp@ 2 cells + dup cell+ rot move drop r> ;
! 73:
! 74: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT 11jun93jaw
! 75:
! 76: : source-id ( -- 0 | -1 | fileid )
! 77: loadfile @ dup 0= IF drop linestart @ THEN ;
! 78:
! 79: : save-input ( -- x1 .. xn n )
! 80: >in @
! 81: loadfile @ ?dup
! 82: IF linestart 2@ loadline @ 6
! 83: ELSE loadline @ blk @ linestart @ 5 THEN
! 84: >tib @ swap ; \ >tib for security
! 85:
! 86: : restore-input ( x1 .. xn n -- flag )
! 87: 1- swap >tib @ <> IF discard true EXIT THEN
! 88: 5 = IF loadline ! 2dup linestart 2! rot dup loadfile !
! 89: reposition-file IF drop true EXIT THEN
! 90: refill 0= IF drop true EXIT THEN
! 91: ELSE linestart ! blk !
! 92: dup loadline @ <> IF 2drop true EXIT THEN
! 93: loadline !
! 94: THEN
! 95: >in ! false ;
! 96:
! 97:
! 98:
! 99: \ This things we don't need, but for being complete... jaw
! 100:
! 101: \ EXPECT SPAN 17may93jaw
! 102:
! 103: variable span
! 104:
! 105: : expect ( c-addr +len -- )
! 106: 0 rot over
! 107: BEGIN key decode >r 2over = r> or UNTIL
! 108: 2drop nip span ! ;
! 109:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>