--- gforth/Attic/kernal.fs 1995/11/30 18:01:48 1.49 +++ gforth/Attic/kernal.fs 1996/02/09 17:34:11 1.52 @@ -76,15 +76,15 @@ HEX \ Bit string manipulation 06oct92py -Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, -DOES> ( n -- ) + c@ ; +\ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, +\ DOES> ( n -- ) + c@ ; -: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; -: +bit ( addr n -- ) >bit over c@ or swap c! ; +\ : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; +\ : +bit ( addr n -- ) >bit over c@ or swap c! ; -: relinfo ( -- addr ) forthstart dup @ + ; -: >rel ( addr -- n ) forthstart - ; -: relon ( addr -- ) relinfo swap >rel cell / +bit ; +\ : relinfo ( -- addr ) forthstart dup @ + !!bug!! ; +\ : >rel ( addr -- n ) forthstart - ; +\ : relon ( addr -- ) relinfo swap >rel cell / +bit ; \ here allot , c, A, 17dec92py @@ -128,10 +128,13 @@ DOES> ( n -- ) + c@ ; ; immediate -: A! ( addr1 addr2 -- ) \ gforth - dup relon ! ; -: A, ( addr -- ) \ gforth - here cell allot A! ; +\ : A! ( addr1 addr2 -- ) \ gforth +\ dup relon ! ; +\ : A, ( addr -- ) \ gforth +\ here cell allot A! ; +' ! alias A! ( addr1 addr2 -- ) \ gforth +' , alias A, ( addr -- ) \ gforth + \ on off 23feb93py @@ -142,8 +145,8 @@ DOES> ( n -- ) + c@ ; \ name> found 17dec92py -: (name>) ( nfa -- cfa ) - count $1F and + cfaligned ; +: (name>) ( nfa+cell -- cfa ) + 1 cells - name>string + cfaligned ; : name> ( nfa -- cfa ) \ gforth cell+ dup (name>) swap c@ $80 and 0= IF @ THEN ; @@ -158,7 +161,7 @@ DOES> ( n -- ) + c@ ; \ : (find) ( addr count nfa1 -- nfa2 / false ) \ BEGIN dup WHILE dup >r -\ cell+ count $1F and dup >r 2over r> = +\ name>string dup >r 2over r> = \ IF -text 0= IF 2drop r> EXIT THEN \ ELSE 2drop drop THEN r> @ \ REPEAT nip nip ; @@ -720,10 +723,11 @@ variable backedge-locals : ?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 -\ better handled by tools like stack checkers - POSTPONE ?dup POSTPONE if ; immediate restrict +\ better handled by tools like stack checkers. Besides, it's faster. + POSTPONE ?dup-?branch >mark ; immediate restrict + : ?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 dup orig? @@ -878,19 +882,19 @@ Avariable leave-sp leave-stack 3 cells : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do POSTPONE (?do) ?do-like ; immediate restrict -: +DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth plus-do +: +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do POSTPONE (+do) ?do-like ; immediate restrict -: U+DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth u-plus-do +: U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do POSTPONE (u+do) ?do-like ; immediate restrict -: -DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth minus-do +: -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do POSTPONE (-do) ?do-like ; immediate restrict -: U-DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth u-minus-do +: U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do POSTPONE (u-do) ?do-like ; immediate restrict -: FOR ( compilation -- do-sys ; run-time w -- loop-sys ) \ gforth +: FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth POSTPONE (for) POSTPONE begin drop do-dest ( 0 0 0 >leave ) ; immediate restrict @@ -1264,6 +1268,9 @@ G -1 warnings T ! 0A constant #lf ( -- c ) \ gforth : bell #bell emit ; +: cr ( -- ) \ core + \ emit a newline + #lf ( sic! ) emit ; \ : backspaces 0 ?DO #bs emit LOOP ; : >string ( span addr pos1 -- span addr pos1 addr2 len ) @@ -1311,26 +1318,26 @@ defer everychar \ 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 for a output buffer or fast \ screen write -\ : (type) ( addr len -- ) -\ bounds ?DO I c@ emit LOOP ; - ' (type) IS Type +: (emit) ( c -- ) \ gforth + outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? +; + Defer emit ( c -- ) \ core ' (Emit) IS Emit Defer key ( -- c ) \ core ' (key) IS key -\ : form ( -- rows cols ) &24 &80 ; -\ form should be implemented using TERMCAPS or CURSES -\ : rows form drop ; -\ : cols form nip ; - \ Query 07apr93py : refill ( -- flag ) \ core-ext,block-ext,file-ext @@ -1355,8 +1362,8 @@ Defer key ( -- c ) \ core \ 2 c, here char r c, char + c, 0 c, \ 2 c, here char w c, char + c, 0 c, align 4 Constant w/o ( -- fam ) \ file w-o -2 Constant r/w ( -- fam ) \ file r-o -0 Constant r/o ( -- fam ) \ file r-w +2 Constant r/w ( -- fam ) \ file r-w +0 Constant r/o ( -- fam ) \ file r-o \ BIN WRITE-LINE 11jun93jaw @@ -1681,7 +1688,7 @@ DEFER DOERROR \ Cold 13feb93py -\ : .name ( name -- ) cell+ count $1F and type space ; +\ : .name ( name -- ) name>string type space ; \ : words listwords @ \ BEGIN @ dup WHILE dup .name REPEAT drop ; @@ -1748,6 +1755,7 @@ Variable argc Defer 'cold ' noop IS 'cold : cold ( -- ) \ gforth + stdout TO outfile-id pathstring 2@ process-path pathdirs 2! init-included-files 'cold @@ -1761,7 +1769,7 @@ Defer 'cold ' noop IS 'cold cr THEN false to script? - ." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr + ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr ." Type `bye' to exit" loadline off quit ;