init/sys.f

   1 S" :" CREATE ] DOCOL
   2   READ-WORD CREATE
   3   LIT DOCOL ,
   4   ]
   5 EXIT [
   6
   7 : ;
   8   LIT EXIT ,
   9   [ S" [" FIND >CFA , ]
  10   EXIT
  11 [ IMMEDIATE
  12
  13 : IF IMMEDIATE
  14   ' 0BRANCH ,
  15   HERE @
  16   0 ,
  17 ;
  18
  19 : THEN IMMEDIATE
  20   DUP
  21   HERE @ SWAP -
  22   SWAP !
  23 ;
  24
  25 : ELSE IMMEDIATE
  26   ' BRANCH ,
  27   HERE @
  28   0 ,
  29   SWAP DUP HERE @ SWAP - SWAP !
  30 ;
  31
  32 : BEGIN IMMEDIATE HERE @ ;
  33
  34 : AGAIN IMMEDIATE ' BRANCH , HERE @ - , ;
  35
  36 : UNTIL IMMEDIATE ' 0BRANCH , HERE @ - , ;
  37
  38 : ( IMMEDIATE
  39   BEGIN READ-WORD 1 = IF C@ 41 = IF EXIT THEN ELSE DROP THEN AGAIN ;
  40 ( Yay! We now have  comments! )
  41
  42 ( Compile a literal value into the current word. )
  43 : LIT, IMMEDIATE ( x -- ) ' LIT , , ;
  44
  45 : / /MOD DROP ;
  46 : MOD /MOD SWAP DROP ;
  47 : NEG 0 SWAP - ;
  48
  49 ( p n -- ; increment *p by n )
  50 : INC OVER @ + SWAP ! ;
  51
  52 : C, HERE @ C! HERE 1 INC ;
  53
  54 ( p -- v ; fetch 32 bit value; fetches 64 and masks the high bits )
  55 : @32 @ 4294967295 & ;
  56
  57 ( An alternative comment syntax. Reads until the end of the line. )
  58 : \ IMMEDIATE BEGIN KEY 10 = UNTIL ;
  59
  60 ( string* -- buffer length )
  61 : S@ DUP 1 + SWAP C@ ;
  62
  63 ( -- str* ; Put input string into dictionary heap and return address )
  64 : "
  65   HERE @ 0 C, \ We will put the length here
  66   BEGIN KEY DUP C, 34 = UNTIL
  67   HERE @ 1 - 0 OVER C! OVER - OVER C!
  68   ;
  69
  70 \ So far, S" has only worked in immediate mode, which is backwards --
  71 \ actually, the main use-case of this is as a compile-time word. Let's
  72 \ fix that.
  73 : S" IMMEDIATE ' LITSTRING , " DROP ;
  74
  75 ( immediate print string, using HERE space )
  76 : ." HERE @ " S@ TELL HERE ! ;
  77
  78 \ Store a null-terminated UTF-16 string HERE, and return a pointer to
  79 \ its buffer at runtime.
  80 : UTF16" HERE @ BEGIN KEY DUP C, 0 C, 34 = UNTIL 0 HERE @ 2 - C! ;
  81
  82 : NEWLINE 10 EMIT ;
  83
  84 : SPACE 32 EMIT ;
  85
  86 : .X .U SPACE ;
  87
  88 ( RPT ... [ IFZEND ... ]* DONE )
  89 : RPT IMMEDIATE ' BRANCH , 24 , ' BRANCH , 0 , HERE @ ;
  90
  91 : DONE IMMEDIATE ' BRANCH , DUP HERE @ - , 8 - HERE @ OVER - SWAP ! ;
  92
  93 : IFZEND IMMEDIATE ' 0BRANCH , DUP 16 - HERE @ - , ;
  94
  95 ( v -- ; print decimal number )
  96 : . DUP IF 10 /MOD SWAP DUP IF . ELSE DROP THEN THEN 48 + EMIT ;
  97
  98 ( Read a number from standard input. )
  99 : READ-NUMBER READ-WORD PARSE-NUMBER ;
 100
 101 ( a b -- c ; logical AND wrt !=0 )
 102 : AND IF IF 1 ELSE 0 THEN ELSE DROP 0 THEN ;
 103
 104 ( a b -- c ; logical OR wrt !=0 )
 105 : OR IF DROP 1 ELSE IF 1 ELSE 0 THEN THEN ;
 106
 107 ( v [word] -- ; Declare a CONSTANT that returns a value )
 108 : CONSTANT READ-WORD CREATE LIT DOCOL , LIT LIT , , LIT EXIT , ;
 109
 110 ( p n -- p+n ; define name for field address of given size )
 111 : FIELD* OVER CONSTANT + ;
 112
 113 ( p -- p+8 ; define name for current field 64-bit value )
 114 : FIELD@ DUP @ CONSTANT 8 + ;
 115
 116 ( v lo hi -- v x ; x = lo <= v and v <= hi )
 117 : RANGE 2 PICK < IF DROP 0 ELSE OVER SWAP < IF 0 ELSE 1 THEN THEN ;
 118
 119 \ ######## Handling hexadecimal codes: 0x...
 120
 121 0 1 - CONSTANT -1
 122
 123 ( -- v ; read next character as a hexcode value or -1 )
 124 : HEX
 125   KEY 48 57 RANGE IF 48 -
 126   ELSE 65 70 RANGE IF 55 -
 127   ELSE 97 102 RANGE IF 87 -
 128   ELSE DROP -1
 129   THEN THEN THEN
 130 ;
 131
 132 ( -- v ; Read indefinite sequence of hex digits, an one character more )
 133 : HEX* 0 RPT HEX DUP 1 + IFZEND 16 * + DONE DROP ;
 134
 135 ( -- ; Read immediately a heax number and compile into dictionary )
 136 : HEX, IMMEDIATE HEX* , ;
 137
 138 ( -- v ; read next 2 characters as hexcode into a byte value )
 139 : HEX2 HEX 16 * HEX + ;
 140
 141 ( -- v ; read next 4 characters as hexcode into a 2-byte value )
 142 : HEX4 HEX2 256 * HEX2 + ;
 143
 144 ( -- v ; read next 8 characters as hexcode into a 4-byte value )
 145 : HEX8 HEX4 65536 * HEX4 + ;
 146
 147 ( c -- ; consume input on the line until character c or newline )
 148 : SCANTO BEGIN KEY 10 OVER = IF DROP 1 ELSE OVER = THEN UNTIL DROP ;
 149
 150 ( v p -- ; lay out 2-byte value as LE )
 151 : C2! 2DUP C! SWAP 256 / SWAP 1 + C! ;
 152
 153 ( v p -- ; lay out 4-byte value as LE )
 154 : C4! 2DUP C2! SWAP 65536 / SWAP 2 + C2! ;
 155
 156 ( v1..vn n -- v1..vn ; reverse the n top elements on the stack using the heap )
 157 : REVERSE
 158   DUP 1 + 8 * R+ \ Allocate frame of n+1 elements (index = 1..n)
 159   DUP R= !       \ Save count at top
 160   BEGIN SWAP OVER 8 * R= + ! 1 - 1 < UNTIL DROP \ copy to return stack
 161   R= @           \ Restore count
 162   BEGIN DUP 8 * R= + @ SWAP 1 - 1 < UNTIL DROP \ copy from return stack
 163   R= @ 1 + 8 * R+ \ Dispose of the frame
 164 ;
 165
 166 ( array i - array &array[i]  ; pointer into 64-bit array )
 167 : [8] 8 * OVER + ;
 168
 169 ( addr n -- ; TELL n bytes )
 170 : .BYTES BEGIN SWAP DUP C@ SPACE .U 1 + SWAP 1 - DUP 0 = UNTIL DROP DROP ;
 171
 172 ( addr n -- ; TELL n elements )
 173 : .ELEMENTS BEGIN SWAP DUP @ SPACE .U 8 + SWAP 1 - DUP 1 < UNTIL DROP DROP ;