src/lib.4th

   1 : / /MOD SWAP DROP ;
   2 : MOD /MOD DROP ;
   3
   4 : '\n' 10 ;
   5 : BL 32 ;
   6
   7 : CR '\n' emit ;
   8 : SPACE BL emit ;
   9
  10 : NEGATE 0 swap - ;
  11
  12 : TRUE -1 ;
  13 : FALSE 0 ;
  14 : NOT 0= ;
  15
  16 : LITERAL IMMEDIATE ' LIT , , ;
  17
  18 : ':'
  19     [
  20     CHAR :
  21     ]
  22     LITERAL
  23 ;
  24
  25 : ';' [ CHAR ; ] LITERAL ;
  26 : '(' [ CHAR ( ] LITERAL ;
  27 : ')' [ CHAR ) ] LITERAL ;
  28 : '"' [ CHAR " ] LITERAL ;
  29 : 'A' [ CHAR A ] LITERAL ;
  30 : '0' [ CHAR 0 ] LITERAL ;
  31 : '-' [ CHAR - ] LITERAL ;
  32 : '.' [ CHAR . ] LITERAL ;
  33
  34 \ While compiling, '[COMPILE] word' compiles 'word' if it would otherwise be IMMEDIATE.
  35 : [COMPILE] IMMEDIATE
  36         WORD            \ get the next word
  37         FIND            \ find it in the dictionary
  38         >CFA            \ get its codeword
  39         ,               \ and compile that
  40 ;
  41
  42 \ RECURSE makes a recursive call to the current word that is being compiled.
  43 \
  44 \ Normally while a word is being compiled, it is marked HIDDEN so that references to the
  45 \ same word within are calls to the previous definition of the word.  However we still have
  46 \ access to the word which we are currently compiling through the LATEST pointer so we
  47 \ can use that to compile a recursive call.
  48 : RECURSE IMMEDIATE
  49         LATEST @        \ LATEST points to the word being compiled at the moment
  50         >CFA            \ get the codeword
  51         ,               \ compile it
  52 ;
  53
  54 \       CONTROL STRUCTURES ----------------------------------------------------------------------
  55 \
  56 \ So far we have defined only very simple definitions.  Before we can go further, we really need to
  57 \ make some control structures, like IF ... THEN and loops.  Luckily we can define arbitrary control
  58 \ structures directly in FORTH.
  59 \
  60 \ Please note that the control structures as I have defined them here will only work inside compiled
  61 \ words.  If you try to type in expressions using IF, etc. in immediate mode, then they won't work.
  62 \ Making these work in immediate mode is left as an exercise for the reader.
  63
  64 \ condition IF true-part THEN rest
  65 \       -- compiles to: --> condition 0BRANCH OFFSET true-part rest
  66 \       where OFFSET is the offset of 'rest'
  67 \ condition IF true-part ELSE false-part THEN
  68 \       -- compiles to: --> condition 0BRANCH OFFSET true-part BRANCH OFFSET2 false-part rest
  69 \       where OFFSET if the offset of false-part and OFFSET2 is the offset of rest
  70
  71 \ IF is an IMMEDIATE word which compiles 0BRANCH followed by a dummy offset, and places
  72 \ the address of the 0BRANCH on the stack.  Later when we see THEN, we pop that address
  73 \ off the stack, calculate the offset, and back-fill the offset.
  74 : IF IMMEDIATE
  75         ' 0BRANCH ,     \ compile 0BRANCH
  76         HERE @          \ save location of the offset on the stack
  77         0 ,             \ compile a dummy offset
  78 ;
  79
  80 : THEN IMMEDIATE
  81         DUP
  82         HERE @ SWAP -   \ calculate the offset from the address saved on the stack
  83         SWAP !          \ store the offset in the back-filled location
  84 ;
  85
  86 : ELSE IMMEDIATE
  87         ' BRANCH ,      \ definite branch to just over the false-part
  88         HERE @          \ save location of the offset on the stack
  89         0 ,             \ compile a dummy offset
  90         SWAP            \ now back-fill the original (IF) offset
  91         DUP             \ same as for THEN word above
  92         HERE @ SWAP -
  93         SWAP !
  94 ;
  95
  96 \ BEGIN loop-part condition UNTIL
  97 \       -- compiles to: --> loop-part condition 0BRANCH OFFSET
  98 \       where OFFSET points back to the loop-part
  99 \ This is like do { loop-part } while (condition) in the C language
 100 : BEGIN IMMEDIATE
 101         HERE @          \ save location on the stack
 102 ;
 103
 104 : UNTIL IMMEDIATE
 105         ' 0BRANCH ,     \ compile 0BRANCH
 106         HERE @ -        \ calculate the offset from the address saved on the stack
 107         ,               \ compile the offset here
 108 ;
 109
 110 \ BEGIN loop-part AGAIN
 111 \       -- compiles to: --> loop-part BRANCH OFFSET
 112 \       where OFFSET points back to the loop-part
 113 \ In other words, an infinite loop which can only be returned from with EXIT
 114 : AGAIN IMMEDIATE
 115         ' BRANCH ,      \ compile BRANCH
 116         HERE @ -        \ calculate the offset back
 117         ,               \ compile the offset here
 118 ;
 119
 120 \ BEGIN condition WHILE loop-part REPEAT
 121 \       -- compiles to: --> condition 0BRANCH OFFSET2 loop-part BRANCH OFFSET
 122 \       where OFFSET points back to condition (the beginning) and OFFSET2 points to after the whole piece of code
 123 \ So this is like a while (condition) { loop-part } loop in the C language
 124 : WHILE IMMEDIATE
 125         ' 0BRANCH ,     \ compile 0BRANCH
 126         HERE @          \ save location of the offset2 on the stack
 127         0 ,             \ compile a dummy offset2
 128 ;
 129
 130 : REPEAT IMMEDIATE
 131         ' BRANCH ,      \ compile BRANCH
 132         SWAP            \ get the original offset (from BEGIN)
 133         HERE @ - ,      \ and compile it after BRANCH
 134         DUP
 135         HERE @ SWAP -   \ calculate the offset2
 136         SWAP !          \ and back-fill it in the original location
 137 ;
 138
 139 \ UNLESS is the same as IF but the test is reversed.
 140 \
 141 \ Note the use of [COMPILE]: Since IF is IMMEDIATE we don't want it to be executed while UNLESS
 142 \ is compiling, but while UNLESS is running (which happens to be when whatever word using UNLESS is
 143 \ being compiled -- whew!).  So we use [COMPILE] to reverse the effect of marking IF as immediate.
 144 \ This trick is generally used when we want to write our own control words without having to
 145 \ implement them all in terms of the primitives 0BRANCH and BRANCH, but instead reusing simpler
 146 \ control words like (in this instance) IF.
 147 : UNLESS IMMEDIATE
 148         ' NOT ,         \ compile NOT (to reverse the test)
 149         [COMPILE] IF    \ continue by calling the normal IF
 150 ;
 151
 152 \       COMMENTS ----------------------------------------------------------------------
 153 \
 154 \ FORTH allows ( ... ) as comments within function definitions.  This works by having an IMMEDIATE
 155 \ word called ( which just drops input characters until it hits the corresponding ).
 156 : ( IMMEDIATE
 157         1               \ allowed nested parens by keeping track of depth
 158         BEGIN
 159                 KEY             \ read next character
 160                 DUP '(' = IF    \ open paren?
 161                         DROP            \ drop the open paren
 162                         1+              \ depth increases
 163                 ELSE
 164                         ')' = IF        \ close paren?
 165                                 1-              \ depth decreases
 166                         THEN
 167                 THEN
 168         DUP 0= UNTIL            \ continue until we reach matching close paren, depth 0
 169         DROP            \ drop the depth counter
 170 ;
 171
 172 (
 173         From now on we can use ( ... ) for comments.
 174
 175         STACK NOTATION ----------------------------------------------------------------------
 176
 177         In FORTH style we can also use ( ... -- ... ) to show the effects that a word has on the
 178         parameter stack.  For example:
 179
 180         ( n -- )        means that the word consumes an integer (n) from the parameter stack.
 181         ( b a -- c )    means that the word uses two integers (a and b, where a is at the top of stack)
 182                                 and returns a single integer (c).
 183         ( -- )          means the word has no effect on the stack
 184 )
 185
 186 ( Some more complicated stack examples, showing the stack notation. )
 187 : NIP ( x y -- y ) SWAP DROP ;
 188 : TUCK ( x y -- y x y ) DUP ROT ;
 189 : PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u )
 190         1+              ( add one because of 'u' on the stack )
 191         PSP@ SWAP -     ( add to the stack pointer )
 192         @               ( and fetch )
 193 ;
 194
 195 ( With the looping constructs, we can now write SPACES, which writes n spaces to stdout. )
 196 : SPACES        ( n -- )
 197         BEGIN
 198                 DUP 0>          ( while n > 0 )
 199         WHILE
 200                 SPACE           ( print a space )
 201                 1-              ( until we count down to 0 )
 202         REPEAT
 203         DROP
 204 ;
 205
 206 ( Standard words for manipulating BASE. )
 207 : DECIMAL ( -- ) 10 BASE ! ;
 208 : HEX ( -- ) 16 BASE ! ;
 209
 210 (
 211         PRINTING NUMBERS ----------------------------------------------------------------------
 212
 213         The standard FORTH word . (DOT) is very important.  It takes the number at the top
 214         of the stack and prints it out.  However first I'm going to implement some lower-level
 215         FORTH words:
 216
 217         U.R     ( u width -- )  which prints an unsigned number, padded to a certain width
 218         U.      ( u -- )        which prints an unsigned number
 219         .R      ( n width -- )  which prints a signed number, padded to a certain width.
 220
 221         For example:
 222                 -123 6 .R
 223         will print out these characters:
 224                 <space> <space> - 1 2 3
 225
 226         In other words, the number padded left to a certain number of characters.
 227
 228         The full number is printed even if it is wider than width, and this is what allows us to
 229         define the ordinary functions U. and . (we just set width to zero knowing that the full
 230         number will be printed anyway).
 231
 232         Another wrinkle of . and friends is that they obey the current base in the variable BASE.
 233         BASE can be anything in the range 2 to 36.
 234
 235         While we're defining . &c we can also define .S which is a useful debugging tool.  This
 236         word prints the current stack (non-destructively) from top to bottom.
 237 )
 238
 239 ( This is the underlying recursive definition of U. )
 240 : U.            ( u -- )
 241         BASE @ /MOD     ( width rem quot )
 242         ?DUP IF                 ( if quotient <> 0 then )
 243                 RECURSE         ( print the quotient )
 244         THEN
 245
 246         ( print the remainder )
 247         DUP 10 < IF
 248                 '0'             ( decimal digits 0..9 )
 249         ELSE
 250                 10 -            ( hex and beyond digits A..Z )
 251                 'A'
 252         THEN
 253         +
 254         EMIT
 255 ;
 256
 257