X-Git-Url: https://git.rrq.au/?a=blobdiff_plain;f=init%2Fsys.f;h=e6d7836ff6ad54e96031dff6ee175b9878116c52;hb=HEAD;hp=bf79f380a5ea3c80412121172455fac30f5de162;hpb=66a7dc89cdd30b31fab0c529790b79dcf365d068;p=rrq%2Fjonasforth.git

diff --git a/init/sys.f b/init/sys.f
index bf79f38..e6d7836 100644
--- a/init/sys.f
+++ b/init/sys.f
@@ -29,83 +29,145 @@ EXIT [
   SWAP DUP HERE @ SWAP - SWAP !
 ;
 
-: BEGIN IMMEDIATE
-  HERE @
-;
+: BEGIN IMMEDIATE HERE @ ;
 
-: AGAIN IMMEDIATE
-  ' BRANCH ,
-  HERE @ - , ;
+: AGAIN IMMEDIATE ' BRANCH , HERE @ - , ;
+
+: UNTIL IMMEDIATE ' 0BRANCH , HERE @ - , ;
 
 : ( IMMEDIATE
-  BEGIN
-    READ-WORD
-    1 = IF
-      C@ 41 = IF
-        EXIT
-      THEN
-    ELSE
-      DROP
-    THEN
-  AGAIN ; ( Yay! We now have comments! )
-
-: UNTIL IMMEDIATE
-  ' 0BRANCH ,
-  HERE @ - ,
-;
+  BEGIN READ-WORD 1 = IF C@ 41 = IF EXIT THEN ELSE DROP THEN AGAIN ;
+( Yay! We now have  comments! )
 
 ( Compile a literal value into the current word. )
-: LIT, IMMEDIATE ( x -- )
-  ' LIT , , ;
+: LIT, IMMEDIATE ( x -- ) ' LIT , , ;
 
 : / /MOD DROP ;
 : MOD /MOD SWAP DROP ;
 : NEG 0 SWAP - ;
 
-: C,
-  HERE @ C!
-  HERE @ 1 +
-  HERE ! ;
+( p n -- ; increment *p by n )
+: INC OVER @ + SWAP ! ;
+
+: C, HERE @ C! HERE 1 INC ;
 
-: OVER ( a b -- a b a ) SWAP DUP ROT ;
+( p -- v ; fetch 32 bit value; fetches 64 and masks the high bits )
+: @32 @ 4294967295 & ;
 
 ( An alternative comment syntax. Reads until the end of the line. )
-: \ IMMEDIATE
-  BEGIN
-    KEY
-  10 = UNTIL ;
+: \ IMMEDIATE BEGIN KEY 10 = UNTIL ;
+
+( string* -- buffer length )
+: S@ DUP 1 + SWAP C@ ;
+
+( -- str* ; Put input string into dictionary heap and return address )
+: "
+  HERE @ 0 C, \ We will put the length here
+  BEGIN KEY DUP C, 34 = UNTIL
+  HERE @ 1 - 0 OVER C! OVER - OVER C!
+  ;
 
 \ So far, S" has only worked in immediate mode, which is backwards --
 \ actually, the main use-case of this is as a compile-time word. Let's
 \ fix that.
-: S" IMMEDIATE
-  ' LITSTRING ,
-  HERE @ 0 C, \ We will put the length here
-  0
-  BEGIN
-    1 +
-    KEY DUP C,
-  34 = UNTIL
-  \ Remove final "
-    HERE @ 1 - HERE !
-    1 -
-  SWAP C! ;
-
-( Compile the given string into the current word directly. )
-: STORE-STRING ( str len -- )
-  BEGIN
-    OVER C@ C,
-    SWAP 1 + SWAP
-  1 - DUP 0 = UNTIL
-  DROP DROP ;
+: S" IMMEDIATE ' LITSTRING , " DROP ;
+
+( immediate print string, using HERE space )
+: ." HERE @ " S@ TELL HERE ! ;
+
+\ Store a null-terminated UTF-16 string HERE, and return a pointer to
+\ its buffer at runtime.
+: UTF16" HERE @ BEGIN KEY DUP C, 0 C, 34 = UNTIL 0 HERE @ 2 - C! ;
 
 : NEWLINE 10 EMIT ;
 
 : SPACE 32 EMIT ;
 
+: .X .U SPACE ;
+
+( RPT ... [ IFZEND ... ]* DONE )
+: RPT IMMEDIATE ' BRANCH , 24 , ' BRANCH , 0 , HERE @ ;
+
+: DONE IMMEDIATE ' BRANCH , DUP HERE @ - , 8 - HERE @ OVER - SWAP ! ;
+
+: IFZEND IMMEDIATE ' 0BRANCH , DUP 16 - HERE @ - , ;
+
+( v -- ; print decimal number )
+: . DUP IF 10 /MOD SWAP DUP IF . ELSE DROP THEN THEN 48 + EMIT ;
+
 ( Read a number from standard input. )
 : READ-NUMBER READ-WORD PARSE-NUMBER ;
 
-: RESTART S" rrq's UEFI boot using jonasforth." TELL NEWLINE ;
+( a b -- c ; logical AND wrt !=0 )
+: AND IF IF 1 ELSE 0 THEN ELSE DROP 0 THEN ;
+
+( a b -- c ; logical OR wrt !=0 )
+: OR IF DROP 1 ELSE IF 1 ELSE 0 THEN THEN ;
+
+( v [word] -- ; Declare a CONSTANT that returns a value )
+: CONSTANT READ-WORD CREATE LIT DOCOL , LIT LIT , , LIT EXIT , ;
+
+( p n -- p+n ; define name for field address of given size )
+: FIELD* OVER CONSTANT + ;
+
+( p -- p+8 ; define name for current field 64-bit value )
+: FIELD@ DUP @ CONSTANT 8 + ;
+
+( v lo hi -- v x ; x = lo <= v and v <= hi )
+: RANGE 2 PICK < IF DROP 0 ELSE OVER SWAP < IF 0 ELSE 1 THEN THEN ;
+
+\ ######## Handling hexadecimal codes: 0x...
+
+0 1 - CONSTANT -1
+
+( -- v ; read next character as a hexcode value or -1 )
+: HEX
+  KEY 48 57 RANGE IF 48 -
+  ELSE 65 70 RANGE IF 55 -
+  ELSE 97 102 RANGE IF 87 -
+  ELSE DROP -1
+  THEN THEN THEN
+;
+
+( -- v ; Read indefinite sequence of hex digits, an one character more )
+: HEX* 0 RPT HEX DUP 1 + IFZEND 16 * + DONE DROP ;
+
+( -- ; Read immediately a heax number and compile into dictionary )
+: HEX, IMMEDIATE HEX* , ;
+
+( -- v ; read next 2 characters as hexcode into a byte value )
+: HEX2 HEX 16 * HEX + ;
+
+( -- v ; read next 4 characters as hexcode into a 2-byte value )
+: HEX4 HEX2 256 * HEX2 + ;
+
+( -- v ; read next 8 characters as hexcode into a 4-byte value )
+: HEX8 HEX4 65536 * HEX4 + ;
+
+( c -- ; consume input on the line until character c or newline )
+: SCANTO BEGIN KEY 10 OVER = IF DROP 1 ELSE OVER = THEN UNTIL DROP ;
+
+( v p -- ; lay out 2-byte value as LE )
+: C2! 2DUP C! SWAP 256 / SWAP 1 + C! ;
+
+( v p -- ; lay out 4-byte value as LE )
+: C4! 2DUP C2! SWAP 65536 / SWAP 2 + C2! ;
+
+( v1..vn n -- v1..vn ; reverse the n top elements on the stack using the heap )
+: REVERSE
+  DUP 1 + 8 * R+ \ Allocate frame of n+1 elements (index = 1..n)
+  DUP R= !       \ Save count at top
+  BEGIN SWAP OVER 8 * R= + ! 1 - 1 < UNTIL DROP \ copy to return stack
+  R= @           \ Restore count
+  BEGIN DUP 8 * R= + @ SWAP 1 - 1 < UNTIL DROP \ copy from return stack
+  R= @ 1 + 8 * R+ \ Dispose of the frame
+;
+
+( array i - array &array[i]  ; pointer into 64-bit array )
+: [8] 8 * OVER + ;
+
+( addr n -- ; TELL n bytes )
+: .BYTES BEGIN SWAP DUP C@ SPACE .U 1 + SWAP 1 - DUP 0 = UNTIL DROP DROP ;
 
-RESTART
+( addr n -- ; TELL n elements )
+: .ELEMENTS BEGIN SWAP DUP @ SPACE .U 8 + SWAP 1 - DUP 1 < UNTIL DROP DROP ;