[BACK]Return to kernal.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/Attic/kernal.fs between versions 1.50 and 1.53

version 1.50, 1996/01/07 17:22:12 version 1.53, 1996/02/19 19:19:34
Line 76  HEX Line 76  HEX
   
 \ 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,
 DOES> ( n -- )  + c@ ;  \ DOES> ( n -- )  + c@ ;
   
 : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;  \ : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;
 : +bit  ( addr n -- )  >bit over c@ or swap c! ;  \ : +bit  ( addr n -- )  >bit over c@ or swap c! ;
   
 : relinfo ( -- addr )  forthstart dup @ + ;  \ : relinfo ( -- addr )  forthstart dup @ + !!bug!! ;
 : >rel  ( addr -- n )  forthstart - ;  \ : >rel  ( addr -- n )  forthstart - ;
 : relon ( addr -- )  relinfo swap >rel cell / +bit ;  \ : relon ( addr -- )  relinfo swap >rel cell / +bit ;
   
 \ here allot , c, A,                                   17dec92py  \ here allot , c, A,                                   17dec92py
   
Line 128  DOES> ( n -- )  + c@ ; Line 128  DOES> ( n -- )  + c@ ;
 ; immediate  ; immediate
   
   
 : A!    ( addr1 addr2 -- ) \ gforth  \ : A!    ( addr1 addr2 -- ) \ gforth
     dup relon ! ;  \    dup relon ! ;
 : A,    ( addr -- ) \ gforth  \ : A,    ( addr -- ) \ gforth
     here cell allot A! ;  \    here cell allot A! ;
   ' ! alias A! ( addr1 addr2 -- ) \ gforth
   ' , alias A, ( addr -- ) \ gforth 
   
   
 \ on off                                               23feb93py  \ on off                                               23feb93py
   
Line 720  variable backedge-locals Line 723  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 878  Avariable leave-sp  leave-stack 3 cells Line 882  Avariable leave-sp  leave-stack 3 cells
 : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )  \ core-ext      question-do  : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )  \ core-ext      question-do
     POSTPONE (?do) ?do-like ; immediate restrict      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      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      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      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      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 (for)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     ( 0 0 0 >leave ) ; immediate restrict      ( 0 0 0 >leave ) ; immediate restrict
Line 957  create s"-buffer /line chars allot Line 961  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 1314  defer everychar Line 1324  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 1353  Defer key ( -- c ) \ core Line 1368  Defer key ( -- c ) \ core
 \ 2 c, here char r c, char + c, 0 c,  \ 2 c, here char r c, char + c, 0 c,
 \ 2 c, here char w c, char + c, 0 c, align  \ 2 c, here char w c, char + c, 0 c, align
 4 Constant w/o ( -- fam ) \ file        w-o  4 Constant w/o ( -- fam ) \ file        w-o
 2 Constant r/w ( -- fam ) \ file        r-o  2 Constant r/w ( -- fam ) \ file        r-w
 0 Constant r/o ( -- fam ) \ file        r-w  0 Constant r/o ( -- fam ) \ file        r-o
   
 \ BIN WRITE-LINE                                        11jun93jaw  \ BIN WRITE-LINE                                        11jun93jaw
   
Line 1746  Variable argc Line 1761  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.50  
changed lines
  Added in v.1.53

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