├── .gitignore ├── .gitattributes ├── README ├── lisp.sh ├── words.lisp └── meta.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | * text=auto 2 | *.sh text eol=lf 3 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Forth metacompiler written in Lisp. At this point, it's completely 2 | ad-hoc and only used to bootstrap one particular Forth implementation 3 | called lbForth. 4 | -------------------------------------------------------------------------------- /lisp.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | FORMS="$*" 4 | 5 | try() { 6 | if type $1 > /dev/null 2>&1; then 7 | $1 $2 "(progn $FORMS)" 8 | exit $? 9 | fi 10 | } 11 | 12 | try sbcl "--noinform --eval" 13 | try clisp "-q -x" 14 | try ecl "-eval" 15 | try ccl "--eval" 16 | try dx86cl "--eval" 17 | try lx86cl "--eval" 18 | try wx86cl "--eval" 19 | try wx86cl64 "--eval" 20 | try gcl "-eval" 21 | 22 | echo No Lisp found. 23 | exit 1 24 | -------------------------------------------------------------------------------- /words.lisp: -------------------------------------------------------------------------------- 1 | (defword immediate:[ () 2 | (setq *state* 'interpret-word) 3 | (values)) 4 | 5 | (defword interpreted:] () 6 | (setq *state* 'compile-word) 7 | (values)) 8 | 9 | (defword interpreted:|:| (&parse name) 10 | (setf (fill-pointer *dictionary*) 0) 11 | (setq *here* 0) 12 | (setq *this-word* name) 13 | (interpreted:])) 14 | 15 | (defun ignore-definition () 16 | (loop until (string= (read-word) ";"))) 17 | 18 | (defword interpreted:|?:| (&parse name) 19 | (if (word-found-p name *vocabulary*) 20 | (ignore-definition) 21 | (interpreted:|:| name))) 22 | 23 | (defword immediate:|;| () 24 | (emit-word "exit") 25 | (output-header *this-word* "dodoes_code" (word-body "docol," 4) (immediatep)) 26 | (do ((end (fill-pointer *dictionary*)) 27 | (i 0 (1+ i))) 28 | ((= i end)) 29 | (output " (cell)~A~:[~;,~]" (aref *dictionary* i) (/= (1+ i) end))) 30 | (immediate:[)) 31 | 32 | ;;; (defword interpreted:immediate () 33 | ;;; ...) 34 | 35 | (defword interpreted:|FORWARD:| (&parse name) 36 | (output-finish) 37 | (output-extern name)) 38 | 39 | (defword interpreted:defer (&parse name) 40 | (output-header name "dodoes_code" (word-body "perform")) 41 | (setq *deferred* (format nil " (cell)~A" (tick "abort")))) 42 | 43 | (defword immediate:is (&parse name) 44 | (emit-literal (word-body name)) 45 | (emit-word "!")) 46 | 47 | (defword interpreted:is (&parse name) 48 | (declare (ignore name)) 49 | (setq *deferred* (format nil " (cell)~A" (pop *control-stack*))) 50 | (values)) 51 | 52 | (defword interpreted:value (x &parse name) 53 | (output-header name "dodoes_code" (word-body "dup" 1)) 54 | (output " (cell)~A," x)) 55 | 56 | (defword interpreted:constant (x &parse name) 57 | (interpreted:value x name)) 58 | 59 | (defword immediate:to (&parse name) 60 | (emit-literal (word-body name)) 61 | (emit-word "!")) 62 | 63 | (defword immediate:does> () 64 | (emit-word "(does>)")) 65 | 66 | (defword interpreted:code (&parse name) 67 | (let ((mangled (format nil "~A_code" (mangle-word name))) 68 | (special-code-p nil)) 69 | (output-finish) 70 | (cond 71 | ((equal (read-word) "\\") 72 | (let ((ret-type (read-word))) 73 | (setq special-code-p t 74 | mangled (read-word)) 75 | (output "~A ~A ~A" ret-type mangled (read-line *input*)))) 76 | (t 77 | (read-line *input*) 78 | (output "xt_t * REGPARM ~A (xt_t *IP, xt_t word)" mangled))) 79 | (output-line "{") 80 | (do ((line (read-line *input*) (read-line *input*))) 81 | ((equalp (string-trim " " line) "end-code")) 82 | (output-line line)) 83 | (unless special-code-p 84 | (output-line " return IP;")) 85 | (output-line "}") 86 | (output-header name (format nil "(code_t *)~A" mangled) "0" nil))) 87 | 88 | ;;;definterpreted end-code 89 | 90 | (defword interpreted:allot (u) 91 | (loop repeat (ceiling u *cell-size*) 92 | do (output " (cell)0,"))) 93 | 94 | (defword interpreted:|,| (x) 95 | (output " (cell)~A," x)) 96 | 97 | (defword interpreted:|'| (&parse name) 98 | (tick name)) 99 | 100 | (defword interpreted:cells (u) 101 | (* *cell-size* u)) 102 | 103 | (defword interpreted:create (&parse name) 104 | (output-header name "dodoes_code" (word-body "noop" 0))) 105 | 106 | (defword immediate:|(| () 107 | (do () 108 | ((eql (read-char *input*) #\))))) 109 | 110 | (defword immediate:\\ () 111 | (do () 112 | ((eql (read-char *input*) #\Newline)))) 113 | 114 | (defword immediate:literal (x) 115 | (emit-literal x)) 116 | 117 | (defword immediate:compile (&parse name) 118 | (emit-literal (tick name)) 119 | (emit-word ",")) 120 | 121 | (defword immediate:[compile] (&parse name) 122 | (emit-word name)) 123 | 124 | (defword immediate:postpone (&parse name) 125 | (if (immediate-word name) 126 | (immediate:[compile] name) 127 | (immediate:compile name))) 128 | 129 | (defword immediate:|'DODOES| () 130 | (emit-literal (format nil "~A_code" (mangle-word "dodoes")))) 131 | 132 | (defword interpreted:cr () 133 | (terpri)) 134 | 135 | (defword interpreted:|.(| () 136 | (format t ".( ~A )" (read-word #\)))) 137 | 138 | (defword immediate:|S"| () 139 | (let ((string (coerce (read-word #\") 'string))) 140 | (emit-literal (concatenate 'string "\"" (quoted string) "\"")) 141 | (emit-literal (length string)))) 142 | 143 | (defword immediate:|."| () 144 | (immediate:|S"|) 145 | (emit-word "type")) 146 | 147 | (defword immediate:ahead () 148 | (emit-branch "branch" :unresolved)) 149 | 150 | (defword immediate:if () 151 | (emit-branch "0branch" :unresolved)) 152 | 153 | (defword immediate:then () 154 | (resolve-branch)) 155 | 156 | (defword immediate:else () 157 | (immediate:ahead) 158 | (cs-roll 1) 159 | (immediate:then)) 160 | 161 | (defword immediate:|ABORT"| () 162 | (immediate:if) 163 | (immediate:|S"|) 164 | (emit-word "cr") 165 | (emit-word "type") 166 | (emit-word "cr") 167 | (emit-word "abort") 168 | (immediate:then)) 169 | 170 | (defword interpreted:here () 171 | *here*) 172 | 173 | (defvar *leave*) 174 | 175 | (defword immediate:do () 176 | (emit-word "2>r") 177 | (setq *leave* nil) 178 | (interpreted:here)) 179 | 180 | (defword immediate:leave () 181 | (immediate:ahead) 182 | (push (pop *control-stack*) *leave*) 183 | (values)) 184 | 185 | (defword immediate:loop () 186 | (emit-literal "1") 187 | (emit-loop "(+loop)")) 188 | 189 | (defword immediate:+loop () 190 | (emit-loop "(+loop)")) 191 | 192 | (defword immediate:begin () 193 | (interpreted:here)) 194 | 195 | (defword immediate:again (x) 196 | (emit-branch "branch" x)) 197 | 198 | (defword immediate:while () 199 | (immediate:if) 200 | (cs-roll 1)) 201 | 202 | (defword immediate:repeat (x) 203 | (immediate:again x) 204 | (immediate:then)) 205 | 206 | (defword immediate:until (x) 207 | (emit-branch "0branch" x)) 208 | 209 | (defword interpreted:+ (n1 n2) 210 | (+ n1 n2)) 211 | 212 | (defword interpreted:- (n1 n2) 213 | (- n1 n2)) 214 | 215 | (defword interpreted:1+ (n) 216 | (1+ n)) 217 | 218 | (defword interpreted:* (n1 n2) 219 | (* n1 n2)) 220 | 221 | (defword interpreted:lshift (n1 n2) 222 | (ash n1 n2)) 223 | 224 | (defword interpreted:char (&parse name) 225 | (char-code (char name 0))) 226 | 227 | (defword immediate:[char] (&parse name) 228 | (let ((char (char name 0))) 229 | (emit-literal (cond 230 | ((char= char #\') "'\\''") 231 | ((char= char #\\) "'\\\\'") 232 | (t (format nil "'~A'" char)))))) 233 | 234 | (defword immediate:|[']| (&parse name) 235 | (emit-literal (tick name))) 236 | 237 | (defword interpreted:variable (&parse name) 238 | (output-header name "dodoes_code" (word-body "noop" 0)) 239 | (output-line " 0")) 240 | 241 | (defword interpreted:cell () 242 | *cell-size*) 243 | 244 | (defword immediate:cell () 245 | (emit-literal *cell-size*)) 246 | 247 | (defword immediate:name_length () 248 | (emit-literal *name-size*)) 249 | 250 | (defword immediate:to_next () 251 | (emit-literal *next-offset*)) 252 | 253 | (defword immediate:to_code () 254 | (emit-literal *code-offset*)) 255 | 256 | (defword immediate:to_does () 257 | (emit-literal *does-offset*)) 258 | 259 | (defword immediate:to_body () 260 | (emit-literal *body-offset*)) 261 | 262 | (defword interpreted:invert (u) 263 | (mask-word (lognot u))) 264 | 265 | (defword interpreted:rshift (n u) 266 | (ash n (- u))) 267 | 268 | (defword interpreted:= (n1 n2) 269 | (if (= n1 n2) -1 0)) 270 | 271 | (defword interpreted:> (n1 n2) 272 | (if (> n1 n2) -1 0)) 273 | 274 | (defword immediate:[defined] (&parse name) 275 | (if (word-found-p name *vocabulary*) -1 0)) 276 | 277 | (defword immediate:[undefined] (&parse name) 278 | (interpreted:invert (immediate:[defined] name))) 279 | 280 | (defword interpreted:include (&parse name) 281 | (interpret-file name)) 282 | 283 | (defword immediate:[if] (n) 284 | (when (zerop n) 285 | (skip-until "[then]" "[else]"))) 286 | 287 | (defword immediate:[else] () 288 | (skip-until "[then]")) 289 | 290 | (defword immediate:[then] () 291 | nil) 292 | 293 | ;;; Print control stack. 294 | (defword immediate:.cs () 295 | (format *trace-output* "<~D> " (length *control-stack*)) 296 | (dolist (x (reverse *control-stack*)) 297 | (format *trace-output* "~A " x))) 298 | -------------------------------------------------------------------------------- /meta.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- lisp -*- Copyright 2004, 2013-2017 Lars Brinkhoff 2 | 3 | ;;; Meta compiler to C target. 4 | ;; 5 | ;; Usage: (compile-forth "nucleus.fth" "kernel.fth") 6 | ;; 7 | ;; The output is a C file containing a dictionary with a linked list 8 | ;; of "struct word" as defined by forth.h. CODE words are emitted as 9 | ;; C functions, and colon definitions generate indirect threaded code. 10 | 11 | ;;; Words (partially) supported by this meta compiler: 12 | ;; 13 | ;; ( \ [IF] [ELSE] [THEN] [DEFINED] [UNDEFINED] INCLUDE 14 | ;; : ; IMMEDIATE DOES> DEFER CODE END-CODE 15 | ;; VARIABLE VALUE CREATE ALLOT HERE , ' CELLS INVERT RSHIFT CHAR > = + - 16 | ;; [CHAR] ['] [ ] LITERAL POSTPONE COMPILE [COMPILE] 'DODOES TO IS ." S" 17 | ;; ABORT" AHEAD IF ELSE THEN DO LEAVE LOOP +LOOP BEGIN AGAIN WHILE REPEAT 18 | ;; UNTIL CELL NAME_LENGTH TO_NEXT TO_CODE TO_DOES TO_BODY 19 | ;; .CS 20 | 21 | ;;; Restrictions and special features: 22 | ;; 23 | ;; Many words are immediate and only work in compilation mode, 24 | ;; i.e. they always append code to the current definition. 25 | ;; 26 | ;; CODE may be followed by a \ comment which specifies the generated C 27 | ;; function declaration. 28 | 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | 32 | (defpackage :meta 33 | (:use :cl)) 34 | 35 | (in-package :meta) 36 | 37 | 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | 40 | ;;; Retreive some information passed from C. 41 | (load "params.lisp") 42 | 43 | (defvar *this-word*) 44 | (defvar *previous-word*) 45 | (defvar *vocabulary* nil) 46 | (defvar *control-stack* nil) 47 | (defvar *state* 'interpret-word) 48 | (defvar *input*) 49 | (defvar *output*) 50 | (defvar *here* 0) 51 | (defvar *finished-p* t) 52 | (defvar *dictionary* (make-array 0 :adjustable t :fill-pointer 0)) 53 | (defvar *deferred* nil) 54 | 55 | (defun trivial-quit () 56 | #+sbcl 57 | (#.(or (find-symbol "EXIT" "SB-EXT") (find-symbol "QUIT" "SB-EXT"))) 58 | #+clisp 59 | (ext:quit) 60 | #+ecl 61 | (si:quit) 62 | #+ccl 63 | (ccl:quit) 64 | #+gcl 65 | (lisp:bye) 66 | #-(or sbcl clisp ecl ccl gcl) 67 | (implementation-dependent-quit)) 68 | 69 | #-ecl 70 | (declaim (ftype function interpret-file compile-word mangle-char mangle-word 71 | output output-line output-name output-finish quoted read-word 72 | whitespacep)) 73 | 74 | (defun output-extern (name) 75 | (output "extern struct word ~A_word;" (mangle-word name))) 76 | 77 | (defun cl-user::compile-forth (&rest input-files 78 | &aux 79 | (output-file (output-name input-files))) 80 | (with-open-file (*output* output-file :direction :output 81 | :if-exists :supersede) 82 | (output-line "#include \"forth.h\"") 83 | (output-extern "docol,") 84 | (let ((*previous-word* "0")) 85 | (dolist (file input-files) 86 | (interpret-file file)) 87 | (output-finish))) 88 | (trivial-quit)) 89 | 90 | (defun interpret-file (file) 91 | (loop for path in '("" "src/") 92 | for file-path = (concatenate 'string path file) 93 | when (probe-file file-path) do 94 | (with-open-file (*input* file-path) 95 | (do ((word (read-word) (read-word))) 96 | ((null word)) 97 | (funcall *state* word))))) 98 | 99 | (defun emit (string) 100 | (unless (stringp string) 101 | (setq string (format nil "~A" string))) 102 | (vector-push-extend string *dictionary*) 103 | (incf *here* *cell-size*) 104 | (values)) 105 | 106 | (defun trunc-word (word) 107 | (subseq word 0 (min (length word) (1- *name-size*)))) 108 | 109 | (defun tick (word) 110 | (format nil "&~A_word" (mangle-word word))) 111 | 112 | (defun word-body (word &optional (n 0)) 113 | (format nil "~A.param[~D]" (tick word) n)) 114 | 115 | (defun branch-target (dest) 116 | (word-body *this-word* (floor dest *cell-size*))) 117 | 118 | (defun emit-word (word) 119 | (emit (tick word))) 120 | 121 | (defun emit-literal (x) 122 | (emit-word "(literal)") 123 | (if (and (integerp x) (plusp x)) 124 | (emit (format nil "~DU" x)) 125 | (emit x))) 126 | 127 | (defun emit-branch (word dest) 128 | (emit-word word) 129 | (if (eq dest :unresolved) 130 | (push *here* *control-stack*) 131 | (setq dest (branch-target dest))) 132 | (emit dest)) 133 | 134 | (defun resolve-branch (&optional (orig (pop *control-stack*))) 135 | (setf orig (floor orig *cell-size*)) 136 | (setf (aref *dictionary* orig) (branch-target *here*)) 137 | (values)) 138 | 139 | (defun output (format &rest args) 140 | (output-line (apply #'format nil format args))) 141 | 142 | (defun output-line (line) 143 | (fresh-line *output*) 144 | (write-line line *output*) 145 | (values)) 146 | 147 | (defun output-name (files) 148 | (let* ((file (car (last files))) 149 | (pos (position #\/ file))) 150 | (when pos 151 | (setq file (subseq file (1+ pos)))) 152 | (merge-pathnames (make-pathname :type "c") file))) 153 | 154 | (defun output-finish () 155 | (when *deferred* 156 | (output (shiftf *deferred* nil))) 157 | (unless *finished-p* ;(string= *previous-word* "0") 158 | (output-line "} };")) 159 | (setq *finished-p* t)) 160 | 161 | (defvar *peeked-word* nil) 162 | 163 | (defun read-word (&optional (delimiter nil delimp)) 164 | (or (shiftf *peeked-word* nil) 165 | (let ((word-end-p 166 | (if delimp 167 | (lambda (char) (eql char delimiter)) 168 | (progn 169 | (peek-char t *input* nil) 170 | #'whitespacep)))) 171 | (do ((word nil) 172 | (char (read-char *input* nil) (read-char *input* nil))) 173 | ((or (null char) 174 | (funcall word-end-p char)) 175 | word) 176 | (setq word (concatenate 'string word (string char))))))) 177 | 178 | (defun peek-word (&rest args) 179 | (setq *peeked-word* (apply #'read-word args))) 180 | 181 | (defun whitespacep (char) 182 | (or (char= char #\Tab) 183 | (char= char #\Space) 184 | (char= char #\Newline))) 185 | 186 | (defpackage :interpreted 187 | (:use) 188 | (:export ":" "?:" "FORWARD:" "DEFER" "VALUE" "CODE" "ALLOT" "," "'" ".(" "CR" 189 | "CELLS" "CREATE" "HERE" "+" "-" "1+" "*" "CHAR" "VARIABLE" "CELL" "IS" 190 | "]" "INVERT" "RSHIFT" "=" ">" "INCLUDE" "CONSTANT" "LSHIFT")) 191 | 192 | (defpackage :immediate 193 | (:use) 194 | (:export ";" "IS" "TO" "DOES>" "(" "\\" "LITERAL" "POSTPONE" "'DODOES" 195 | "COMPILE" "[COMPILE]" ".\"" "S\"" "ABORT\"" "AHEAD" "IF" "ELSE" 196 | "THEN" "DO" "LEAVE" "LOOP" "+LOOP" "BEGIN" "AGAIN" "WHILE" 197 | "REPEAT" "UNTIL" "[CHAR]" "[']" "CELL" "NAME_LENGTH" "TO_NEXT" 198 | "TO_CODE" "TO_DOES" "TO_BODY" "[" "[DEFINED]" "[UNDEFINED]" 199 | "[IF]" "[ELSE]" "[THEN]" ".CS")) 200 | 201 | (defmacro defword (name lambda-list &body body) 202 | `(progn 203 | (setf (get ',name 'args) ',lambda-list) 204 | (defun ,name ,(remove '&parse lambda-list) ,@body))) 205 | 206 | (defun find-word (word package) 207 | (find-symbol (string-upcase word) package)) 208 | 209 | (defun immediate-word (word) 210 | (find-word word "IMMEDIATE")) 211 | 212 | (defun interpreted-word (word) 213 | (find-word word "INTERPRETED")) 214 | 215 | (defun to-integer (x) 216 | (etypecase x 217 | (number x) 218 | (string (parse-integer x)))) 219 | 220 | (defun execute (word) 221 | (do* ((args nil) 222 | (lambda-list (get word 'args) (rest lambda-list)) 223 | (arg (first lambda-list) (first lambda-list))) 224 | ((null lambda-list) 225 | (let ((value (apply word args))) 226 | (and value (push value *control-stack*)))) 227 | (if (eq arg '&parse) 228 | (setq args (nconc args (list (read-word))) 229 | lambda-list (rest lambda-list)) 230 | (let ((datum (pop *control-stack*)) 231 | (type (char (symbol-name arg) 0))) 232 | (when (member type '(#\N #\U)) 233 | (setq datum (to-integer datum))) 234 | (push datum args))))) 235 | 236 | (defun compile-word (word) 237 | (cond 238 | ((immediate-word word) 239 | (execute (immediate-word word))) 240 | ((multiple-value-bind (i p) (parse-integer word :junk-allowed t) 241 | (when (and i (= p (length word))) 242 | (emit-literal i) 243 | t))) 244 | (t 245 | (emit-word word)))) 246 | 247 | (defun interpret-word (word) 248 | (cond 249 | ((interpreted-word word) 250 | (execute (interpreted-word word))) 251 | ((immediate-word word) 252 | (execute (immediate-word word))) 253 | (t 254 | (push word *control-stack*)))) 255 | 256 | (defun output-header (name code does &optional immediatep) 257 | (push name *vocabulary*) 258 | (let* ((mangled (mangle-word name)) 259 | (latestxt (tick name)) 260 | (name (trunc-word name)) 261 | (len (length name))) 262 | (when immediatep 263 | (setq len (- len))) 264 | (output-finish) 265 | (output "struct word ~A_word = { ~D, \"~A\", ~A, ~A, ~A, {" 266 | mangled len (quoted name) *previous-word* does code) 267 | (setq *previous-word* latestxt) 268 | (setq *finished-p* nil))) 269 | 270 | (defun mangle-word (name) 271 | (cond 272 | ((and (char= (char name 0) #\() 273 | (char= (char name (1- (length name))) #\))) 274 | (concatenate 'string "do" (mangle-word (string-trim "()" name)))) 275 | ((char= (char name (1- (length name))) #\0) 276 | name) 277 | ((equal name "0branch") "zbranch") 278 | ((equal name ">r") "to_r") 279 | ((equal name "2>r") "two_to_r") 280 | ((equal name "r>") "r_from") 281 | ((equal name "2r>") "two_r_from") 282 | ((equal name "0=") "zero_equals") 283 | ((equal name "0<") "zero_less") 284 | ((equal name "0>") "zero_greater") 285 | (t (apply #'concatenate 'string 286 | (map 'list #'mangle-char name))))) 287 | 288 | (defun mangle-char (char) 289 | (case char 290 | (#\! "store") 291 | (#\" "quote") 292 | (#\# "number") 293 | (#\' "tick") 294 | (#\( "paren") 295 | (#\* "star") 296 | (#\+ "plus") 297 | (#\, "comma") 298 | (#\- "minus") 299 | (#\. "dot") 300 | (#\/ "slash") 301 | (#\0 "zero") 302 | (#\1 "one") 303 | (#\2 "two") 304 | (#\3 "three") 305 | (#\4 "four") 306 | (#\: "colon") 307 | (#\; "semicolon") 308 | (#\< "lt") 309 | (#\= "eq") 310 | (#\> "gt") 311 | (#\? "query") 312 | (#\@ "fetch") 313 | (#\[ "lbracket") 314 | (#\] "rbracket") 315 | (#\\ "backslash") 316 | (t (string char)))) 317 | 318 | (defun quoted (name) 319 | (concatenate 'string 320 | (loop for char across name 321 | when (or (eql char #\") (eql char #\\)) 322 | collect #\\ 323 | collect char))) 324 | 325 | 326 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 327 | 328 | (defun immediatep () 329 | (and (equal (peek-word) "immediate") 330 | (read-word))) 331 | 332 | ;;;definterpreted end-code 333 | 334 | (defun roll (n list) 335 | (let ((tail (nthcdr n list))) 336 | (append (list (first tail)) (ldiff list tail) (rest tail)))) 337 | 338 | (defun cs-roll (n) 339 | (setq *control-stack* (roll n *control-stack*)) 340 | (values)) 341 | 342 | (defvar *leave*) 343 | 344 | (defun emit-loop (word) 345 | (emit-word word) 346 | (emit-branch "0branch" (pop *control-stack*)) 347 | (dolist (dest *leave*) 348 | (resolve-branch dest)) 349 | (setq *leave* nil) 350 | (emit-word "unloop")) 351 | 352 | (defun ends-with-p (string1 string2) 353 | (let ((n (- (length string1) (length string2)))) 354 | (and (>= n 0) (string= string1 string2 :start1 n)))) 355 | 356 | (defun mask-word (x) 357 | (logand x (1- (ash 1 (* 8 *cell-size*))))) 358 | 359 | (defun word-found-p (word vocabulary) 360 | (member word vocabulary :test #'string-equal)) 361 | 362 | (defun skip-until (&rest words) 363 | (do ((word (read-word) (read-word))) 364 | ((word-found-p word words)) 365 | (when (string-equal word "[if]") 366 | (skip-until "[then]")))) 367 | 368 | (load "lisp/words.lisp") 369 | --------------------------------------------------------------------------------