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 ;
projects / rrq / jonasforth.git / blobdiff