| 1 | ;--- file: complrb.l |
| 2 | (include "compmacs.l") |
| 3 | |
| 4 | (setq compiler-name '"Lisp Compiler V3.0") |
| 5 | |
| 6 | (setq old-top-level (getd 'top-level)) |
| 7 | (setq original-readtable readtable) |
| 8 | (setq raw-readtable (makereadtable t)) |
| 9 | |
| 10 | ;--- lcfinit : called upon compiler startup. If there are any args |
| 11 | ; on the command line, we build up a call to lcf, which |
| 12 | ; will do the compile. Afterwards we exit. |
| 13 | ; |
| 14 | (def lcfinit |
| 15 | (lambda nil |
| 16 | (cond ((greaterp (argv -1) 1) ; build up list of args |
| 17 | (do ((i (sub1 (argv -1)) (sub1 i)) (arglis)) |
| 18 | ((lessp i 1) |
| 19 | (exit (apply 'liszt arglis))) |
| 20 | (setq arglis (cons (argv i) arglis)))) |
| 21 | (t (patom compiler-name) |
| 22 | (terpr poport) |
| 23 | (putd 'top-level old-top-level))))) |
| 24 | |
| 25 | (putd 'top-level (getd 'lcfinit)) |
| 26 | |
| 27 | |
| 28 | |
| 29 | \f |
| 30 | ;--- lcf - v-x : list containing file name to compile and optionaly |
| 31 | ; and output file name for the assembler source. |
| 32 | ; |
| 33 | (def liszt |
| 34 | (nlambda (v-x) |
| 35 | (prog (piport v-root v-ifile v-sfile v-ofile |
| 36 | vp-ifile vp-sfile vps-crap |
| 37 | vps-include |
| 38 | k-pid v-crap tmp rootreal |
| 39 | tem temr starttime startptime startgccount |
| 40 | fl-asm fl-warn fl-verb fl-inter) |
| 41 | |
| 42 | (setq starttime (syscall 13) ; real time in seconds |
| 43 | startptime (ptime) |
| 44 | startgccount $gccount$) |
| 45 | (setq k-lams (setq k-nlams (setq k-macros nil))) |
| 46 | (cond ((null (boundp 'internal-macros)) |
| 47 | (setq internal-macros nil))) |
| 48 | (cond ((null (boundp 'macros)) |
| 49 | (setq macros nil))) |
| 50 | (setq k-free nil) |
| 51 | (setq er-fatal 0) |
| 52 | (setq k-ptrs nil) |
| 53 | (setq k-disp -4) |
| 54 | (setq k-fnum 0) ; function number |
| 55 | (setq w-bind nil) |
| 56 | (setq vps-include nil) |
| 57 | (setq twa-list nil) |
| 58 | |
| 59 | (setq x-spec (gensym 'S)) ; flag for special atom |
| 60 | ; declare these special |
| 61 | (flag nil x-spec) |
| 62 | (flag t x-spec) |
| 63 | |
| 64 | (sstatus feature complr) |
| 65 | |
| 66 | ; process input form |
| 67 | (setq fl-asm t ; assembler file assembled |
| 68 | fl-warn t ; print warnings |
| 69 | fl-verb t ; be verbose |
| 70 | fl-macl nil ; compile maclisp file |
| 71 | fl-inter nil ; print intermediate forms |
| 72 | ) |
| 73 | |
| 74 | (do ((i v-x (cdr i))) ; for each argument |
| 75 | ((null i)) |
| 76 | (setq tem (aexplodec (car i))) |
| 77 | |
| 78 | (cond ((eq '- (car tem)) ; if switch |
| 79 | (do ((j (cdr tem) (cdr j))) |
| 80 | ((null j)) |
| 81 | (cond ((eq 'S (car j)) (setq fl-asm nil)) |
| 82 | ((eq 'm (car j)) (setq fl-macl t)) |
| 83 | ((eq 'o (car j)) (setq v-ofile (cadr i) |
| 84 | i (cdr i))) |
| 85 | ((eq 'w (car j)) (setq fl-warn t)) |
| 86 | ((eq 'q (car j)) (setq fl-verb nil)) |
| 87 | ((eq 'i (car j)) (setq fl-inter t)) |
| 88 | (t (comp-gerr "Unknown switch: " |
| 89 | (car j)))))) |
| 90 | ((null v-root) |
| 91 | (setq temr (reverse tem)) |
| 92 | (cond ((and (eq 'l (car temr)) |
| 93 | (eq '"." (cadr temr))) |
| 94 | (setq rootreal nil) |
| 95 | (setq v-root (apply 'concat (reverse (cddr temr))))) |
| 96 | (t (setq v-root (car i) |
| 97 | rootreal t)))) |
| 98 | |
| 99 | (t (comp-gerr "Extra input file name: " (car i))))) |
| 100 | |
| 101 | |
| 102 | |
| 103 | ; now see what the arguments have left us |
| 104 | |
| 105 | (cond ((null v-root) |
| 106 | (comp-gerr "No file for input")) |
| 107 | ((or (portp |
| 108 | (setq vp-ifile |
| 109 | (car (errset (infile |
| 110 | (setq v-ifile |
| 111 | (concat v-root '".l"))) |
| 112 | nil)))) |
| 113 | (and rootreal |
| 114 | (portp |
| 115 | (setq vp-ifile |
| 116 | (car (errset |
| 117 | (infile (setq v-ifile v-root)) |
| 118 | nil))))))) |
| 119 | (t (comp-gerr "Couldn't open the source file :" |
| 120 | (or v-ifile)))) |
| 121 | |
| 122 | |
| 123 | (setq k-pid (apply 'concat (cons 'F (cvt (syscall 20))))) |
| 124 | ; determine the name of the .s file |
| 125 | ; strategy: if fl-asm is t (only assemble) use (v-root).s |
| 126 | ; else use /tmp/(k-pid).s |
| 127 | ; |
| 128 | (cond (fl-asm (setq v-sfile (concat '"/tmp/" |
| 129 | k-pid |
| 130 | '".s"))) |
| 131 | (t (setq v-sfile (concat v-root '".s")))) |
| 132 | |
| 133 | (cond ((not (portp (setq vp-sfile |
| 134 | (car (errset (outfile v-sfile) |
| 135 | nil))))) |
| 136 | (comp-gerr "Couldn't open the .s file: " |
| 137 | (or v-sfile)))) |
| 138 | |
| 139 | |
| 140 | ; determine the name of the .o file (object file) |
| 141 | ; strategy: if we aren't supposed to assemble the .s file |
| 142 | ; don't worry about a name |
| 143 | ; else if a name is given, use it |
| 144 | ; else if use (v-root).o |
| 145 | (cond ((or v-ofile (null fl-asm))) ;ignore |
| 146 | (t (setq v-ofile (concat v-root '".o")))) |
| 147 | |
| 148 | (cond ((checkfatal) (return 1))) |
| 149 | |
| 150 | (setq readtable (makereadtable nil)) ; use new readtable |
| 151 | |
| 152 | |
| 153 | ; make i/o descriptors to point to crap file then |
| 154 | ; unlink crap file so if we die while compiling the crap |
| 155 | ; file will disappear |
| 156 | (setq v-crap (concat k-pid k-fnum 'crap)) |
| 157 | (setq tmp (outfile v-crap)) ; create output first |
| 158 | (setq vps-crap (cons (infile v-crap) tmp)) |
| 159 | (apply 'syscall `(10 ',v-crap)) ; unlink it |
| 160 | |
| 161 | (emit1 `(".." ,k-pid ,k-fnum :)) |
| 162 | (emit1 '".long linker") |
| 163 | (emit1 '".long BINDER") |
| 164 | |
| 165 | ; if the macsyma flag is set, change the syntax to the |
| 166 | ; maclisp standard syntax. We must be careful that we |
| 167 | ; dont clobber any syntax changes made by files preloaded |
| 168 | ; into the compiler. |
| 169 | |
| 170 | (cond (fl-macl (setsyntax '\/ 143) ; 143 = vesc |
| 171 | |
| 172 | (cond ((equal 143 (status syntax \\)) |
| 173 | (setsyntax '\\ 2))) |
| 174 | |
| 175 | (setsyntax '\| 138) ; 138 = vdq |
| 176 | (cond ((equal 138 (status syntax \")) |
| 177 | (setsyntax '\" 2))) |
| 178 | (cond ((equal 198 (status syntax \[)) |
| 179 | (setsyntax '\[ 2) |
| 180 | (setsyntax '\] 2))) |
| 181 | (setq ibase 8.) |
| 182 | (sstatus uctolc t) |
| 183 | |
| 184 | (flag 'ibase x-spec) ; to be special |
| 185 | (flag 'base x-spec) |
| 186 | (flag 'tty x-spec) |
| 187 | |
| 188 | (errset (cond ((null (getd 'macsyma-env)) |
| 189 | (load 'machacks))) |
| 190 | nil))) |
| 191 | |
| 192 | (cond ((checkfatal) (return 1))) ; leave if fatal errors |
| 193 | |
| 194 | (comp-note "Compilation begins with " (or compiler-name)) |
| 195 | (comp-note "source: " (or v-ifile) ", result: " |
| 196 | (cond (fl-asm v-ofile) (t v-sfile))) |
| 197 | (setq piport vp-ifile) ; set to standard input |
| 198 | |
| 199 | loop |
| 200 | ;(cond ((atom (errset (do ((i (read) (read))) |
| 201 | ; ((eq i 'eof) nil) |
| 202 | ; (cleanup) |
| 203 | ; (lcfform i)))) |
| 204 | ; (patom '"error during compilation, I quit"))) |
| 205 | |
| 206 | (cond ((atom (errset |
| 207 | (do ((i (read piport '<<end-of-file>>) |
| 208 | (read piport '<<end-of-file>>))) |
| 209 | ((eq i '<<end-of-file>>) nil) |
| 210 | (cleanup) |
| 211 | (catch (lcfform i) Comp-error)))) |
| 212 | (comp-note "Lisp error during compilation") |
| 213 | (setq piport nil) |
| 214 | (setq er-fatal (add1 er-fatal)) |
| 215 | (return 1))) |
| 216 | |
| 217 | (close piport) |
| 218 | |
| 219 | (cond ((checkfatal) (return 1))) |
| 220 | |
| 221 | ; if doing special character stuff (maclisp) reassert |
| 222 | ; the state |
| 223 | |
| 224 | (cond (vps-include |
| 225 | (comp-note " done include") |
| 226 | (setq piport (car vps-include)) |
| 227 | (setq vps-include (cdr vps-include)) |
| 228 | (go loop))) |
| 229 | |
| 230 | ; reset input base |
| 231 | (setq ibase 10.) |
| 232 | |
| 233 | |
| 234 | (close (cdr vps-crap)) |
| 235 | |
| 236 | (setq vp-ifile (car vps-crap)) ; read crap file |
| 237 | |
| 238 | ((lambda (readtable) |
| 239 | (do ((i (read vp-ifile '<<end-of-file>>) |
| 240 | (read vp-ifile '<<end-of-file>>))) |
| 241 | ((eq i '<<end-of-file>>) nil) |
| 242 | (setq w-bind (cons (list 0 i 'Crap) w-bind))) |
| 243 | |
| 244 | (cm-alist)) |
| 245 | raw-readtable) |
| 246 | |
| 247 | (close vp-sfile) ; close assembler language file |
| 248 | (comp-note "Compilation complete") |
| 249 | |
| 250 | (setq tem (Divide (difference (syscall 13) starttime) 60)) |
| 251 | (comp-note " Real time: " (car tem) " minutes, " |
| 252 | (cadr tem) " seconds") |
| 253 | (setq tem (ptime)) |
| 254 | (setq temr (Divide (difference (car tem) (car startptime)) |
| 255 | 3600)) |
| 256 | (comp-note " CPU time: " (car temr) " minutes, " |
| 257 | (quotient (cadr temr) 60.0) " seconds") |
| 258 | (setq temr (Divide (difference (cadr tem) (cadr startptime)) |
| 259 | 3600)) |
| 260 | (comp-note " of which " (car temr) " minutes and " |
| 261 | (quotient (cadr temr) 60.0) |
| 262 | " seconds were for the " |
| 263 | (difference $gccount$ startgccount) |
| 264 | " gcs which were done") |
| 265 | |
| 266 | |
| 267 | (cond (fl-asm ; assemble file |
| 268 | (comp-note "Assembly begins") |
| 269 | (cond ((not |
| 270 | (zerop |
| 271 | (setq tmp |
| 272 | (apply 'process |
| 273 | (ncons (concat '"as -o " |
| 274 | v-ofile |
| 275 | '" " |
| 276 | v-sfile)))))) |
| 277 | (comp-gerr "Assembler detected error, code: " |
| 278 | (or tmp))) |
| 279 | (t (comp-note "Assembly completed successfully"))))) |
| 280 | (cond (fl-asm (apply 'syscall `(10 ',v-sfile)))) |
| 281 | |
| 282 | (setq readtable original-readtable) |
| 283 | (return 0)))) |
| 284 | |
| 285 | (def checkfatal |
| 286 | (lambda nil |
| 287 | (cond ((greaterp er-fatal 0) |
| 288 | (comp-note "Compilation aborted") |
| 289 | t)))) |
| 290 | \f |
| 291 | |
| 292 | ;--- lcfform - i : form to compile |
| 293 | ; This compiles one form. |
| 294 | ; |
| 295 | (def lcfform |
| 296 | (lambda (i) |
| 297 | (prog (tmp v-x) |
| 298 | ; macro expand |
| 299 | (setq i (cmacroexpand i)) |
| 300 | ; now look at what is left |
| 301 | (cond ((eq (car i) 'def) ; jkf mod |
| 302 | (cond (fl-verb (print (cadr i)) (terpr)(drain))) |
| 303 | (dodef i)) |
| 304 | ((eq (car i) 'declare) (dodcl i)) |
| 305 | ((eq (car i) 'eval-when) (doevalwhen i)) |
| 306 | ((and (eq (car i) 'progn) (equal (cadr i) '(quote compile))) |
| 307 | ((lambda (internal-macros) ; compile macros too |
| 308 | (mapc 'lcfform (cddr i))) |
| 309 | t)) |
| 310 | ((or (eq (car i) '"%include") |
| 311 | (eq (car i) '"include")) |
| 312 | (cond ((or (portp (setq v-x |
| 313 | (car (errset (infile (cadr i)) nil)))) |
| 314 | (portp (setq v-x |
| 315 | (car (errset (infile (concat '"/usr/lib/lisp" |
| 316 | (cadr i))) |
| 317 | nil))))) |
| 318 | (setq vps-include (cons piport vps-include)) |
| 319 | (setq piport v-x) |
| 320 | (comp-note " INCLUDEing file: " (cadr i))) |
| 321 | (t (comp-gerr "Cannot open include file: " (cadr i))))) |
| 322 | (t ((lambda (readtable) |
| 323 | (print i (cdr vps-crap)) |
| 324 | (terpr (cdr vps-crap))) |
| 325 | raw-readtable)))))) |
| 326 | |
| 327 | ;--- cmacroexpand - i : functional form |
| 328 | ; the form is macro expanded on the top level as many times as |
| 329 | ; possible. |
| 330 | ; |
| 331 | (def cmacroexpand |
| 332 | (lambda (i) |
| 333 | (cond ((atom i) i) |
| 334 | (t (do ((j (ismacro (car i)) (ismacro (car i))) |
| 335 | (tmp)) |
| 336 | ((null j) i) |
| 337 | (cond ((bcdp j) |
| 338 | (putd (setq tmp (Gensym nil)) |
| 339 | (mfunction (getentry j) 'nlambda))) |
| 340 | (t (setq tmp (cons 'nlambda (cdr j))))) |
| 341 | (setq i (apply tmp i)) |
| 342 | (cond ((atom i) (return i)))))))) |
| 343 | \f |
| 344 | (def dodef |
| 345 | (lambda (v-f) |
| 346 | (prog (v-n v-t v-c w-save w-ret w-labs w-locs) |
| 347 | (setq k-current (setq v-n (cadr v-f))) ; v-n <= name of func |
| 348 | ; add function to approp. list |
| 349 | (cond ((or (eq (setq v-t (caaddr v-f)) 'lambda) |
| 350 | (eq v-t 'lexpr)) |
| 351 | (setq k-lams (cons (list v-n t) k-lams) |
| 352 | k-ftype v-t |
| 353 | v-t 'lambda)) |
| 354 | ((eq v-t 'nlambda) |
| 355 | (setq k-nlams (cons (list v-n t) k-nlams) |
| 356 | k-ftype 'nlambda)) |
| 357 | ((eq v-t 'macro) |
| 358 | (setq k-macros (cons (list v-n (caddr v-f)) k-macros)) |
| 359 | (setq k-ftype 'macro) |
| 360 | (eval v-f) |
| 361 | ; if macros is nil, we do not compile this macro |
| 362 | (cond ((and (null macros) |
| 363 | (null internal-macros)) |
| 364 | (return nil)))) |
| 365 | (t (comp-err (or v-n) " has an unknown function type" |
| 366 | (v-f)))) |
| 367 | |
| 368 | |
| 369 | (setq v-c (concat k-pid k-fnum)) ; v-c <= unique name |
| 370 | (setq k-fnum (add1 k-fnum)) |
| 371 | (cm-bind v-c v-n v-t) ; update k-regs |
| 372 | (setq v-t (f-func (cdaddr v-f))) ; do parse |
| 373 | (emit3 '# v-c v-n) ; put out header |
| 374 | (cm-alst4 v-n) |
| 375 | (cond (fl-inter (print v-t)(terpr))) |
| 376 | (cm-emit v-t v-c)))) ; emit code |
| 377 | |
| 378 | ;--- doevalwhen, process evalwhen directive. This is inadequate. |
| 379 | ; |
| 380 | (def doevalwhen |
| 381 | (lambda (v-f) |
| 382 | (prog (docom dolod) |
| 383 | (setq docom (member 'compile (cadr v-f)) |
| 384 | |
| 385 | dolod (member 'load (cadr v-f))) |
| 386 | (mapc '(lambda (frm) (cond (docom (eval frm))) |
| 387 | (cond (dolod |
| 388 | ((lambda (internal-macros) |
| 389 | (lcfform frm)) |
| 390 | t)))) |
| 391 | (cddr v-f))))) |
| 392 | |
| 393 | \f |
| 394 | ;---- dodcl - v-f declare form |
| 395 | ; process the declare form given. We evaluate each arg |
| 396 | ; |
| 397 | (def dodcl |
| 398 | (lambda (v-f) |
| 399 | (setq v-f (cdr v-f)) |
| 400 | (do ((i (car v-f) (car v-f))) |
| 401 | ((null i)) |
| 402 | (setq v-f (cdr v-f)) |
| 403 | (cond ((getd (car i)) (eval i)) ; if this is a function |
| 404 | (t (comp-warn "Unknown declare attribute: " (car i))))))) |
| 405 | |
| 406 | ;---> handlers for declare forms |
| 407 | ; |
| 408 | (def *fexpr |
| 409 | (nlambda (args) |
| 410 | (mapc '(lambda (v-x) |
| 411 | (setq k-nlams (cons (list v-x t) k-nlams))) |
| 412 | args))) |
| 413 | (def special |
| 414 | (nlambda (v-l) |
| 415 | (mapc '(lambda (v-a) |
| 416 | (unflag v-a x-con) |
| 417 | (flag v-a x-spec)) |
| 418 | v-l) |
| 419 | t)) |
| 420 | (def unspecial |
| 421 | (nlambda (v-l) |
| 422 | (mapc '(lambda (v-a) |
| 423 | (unflag v-a x-spec)) |
| 424 | v-l) |
| 425 | t)) |
| 426 | |
| 427 | (def *expr (nlambda (args) nil)) ; ignore |
| 428 | |
| 429 | (def macros (nlambda (args) (setq macros (car args)))) |
| 430 | ;---> end declare form handlers |
| 431 | |
| 432 | |
| 433 | (def cm-bind |
| 434 | (lambda (v-lab v-atm v-type) |
| 435 | (setq w-bind (cons (list v-lab v-atm v-type) w-bind)))) |
| 436 | |
| 437 | (def cm-emit |
| 438 | (lambda (v-t v-nm) |
| 439 | (setq k-back (setq k-regs nil)) |
| 440 | (setq k-code v-t) |
| 441 | (prog (v-i v-l) |
| 442 | (emit2 '".globl" v-nm) |
| 443 | (emit1 (list v-nm ':)) |
| 444 | next (cond ((null k-code) (return))) |
| 445 | (setq v-i (car k-code)) |
| 446 | (setq k-code (cdr k-code)) |
| 447 | (setq v-l (get (car v-i) x-emit)) |
| 448 | (cond ((null (cdr v-i)) |
| 449 | (funcall v-l) |
| 450 | (go next)) |
| 451 | ((ifflag (car v-i) x-asg) |
| 452 | (setq v-t (e-reg (cadr v-i) nil))) |
| 453 | (t (setq v-t (cadr v-i)))) |
| 454 | (apply v-l (rplaca (cdr v-i) v-t)) |
| 455 | (go next)))) |
| 456 | \f |
| 457 | ;--- cm-alist - print out the list of special lispvalues we reference |
| 458 | ; in compiled code |
| 459 | ; |
| 460 | |
| 461 | (def cm-alist |
| 462 | (lambda nil |
| 463 | (prog (cm-alv) |
| 464 | (cond (faslflag (emit1 '".text")) |
| 465 | (t (emit1 '".data"))) |
| 466 | (emit1 '".align 2") |
| 467 | (emit1 '"lbnp: .long _bnp") |
| 468 | (emit1 '"lfun: .long __qfuncl") |
| 469 | (emit1 '"lf4: .long __qf4") |
| 470 | (emit1 '"lf3: .long __qf3") |
| 471 | (emit1 '"lf2: .long __qf2") |
| 472 | (emit1 '"lf1: .long __qf1") |
| 473 | (emit1 '"lf0: .long __qf0") |
| 474 | (emit2 '"lgc: .long" 0) |
| 475 | (emit1 '"linker:" ) |
| 476 | (mapc 'cm-alst1 (reverse k-ptrs)) |
| 477 | (emit2 '".long" -1) |
| 478 | (cond (faslflag (emit1 '".data")) |
| 479 | (t (emit1 '".text"))) |
| 480 | (emit1 '".align 2") |
| 481 | (emit1 '"B:") |
| 482 | (emit1 '"BINDER:") |
| 483 | (mapc 'cm-alst2 (reverse w-bind)) |
| 484 | (emit4 '".long" -1 -1 -1) |
| 485 | (emit1 '"litstrt:") |
| 486 | (mapc 'cm-alst3 (reverse cm-alv)) |
| 487 | (emit1 '"litend:") |
| 488 | (cleanup)))) |
| 489 | |
| 490 | |
| 491 | (def cm-alst1 |
| 492 | (lambda (v-x) |
| 493 | (prog (v-g) |
| 494 | (setq v-g (Gensym 's)) |
| 495 | (emit2 '".long" (list v-g '-B)) |
| 496 | (putprop v-g (car v-x) 'label) |
| 497 | (setq cm-alv (cons v-g cm-alv))))) |
| 498 | |
| 499 | (def cm-alst2 |
| 500 | (lambda (v-x) |
| 501 | (prog (v-g) |
| 502 | (emit2 '".long" (car v-x)) |
| 503 | (setq v-g (Gensym 's)) |
| 504 | (emit2 '".long" (list v-g '-B)) |
| 505 | (putprop v-g (cadr v-x) 'label) |
| 506 | (setq cm-alv (cons v-g cm-alv)) |
| 507 | (setq v-g (caddr v-x)) |
| 508 | (emit2 '".long" |
| 509 | (cond ((eq v-g 'lambda) 0) |
| 510 | ((eq v-g 'nlambda) 1) |
| 511 | ((eq v-g 'macro) 2) |
| 512 | ((eq v-g 'Crap) 99) |
| 513 | (t 'UDEF_TYPE)))))) |
| 514 | |
| 515 | (def cm-alst3 |
| 516 | (lambda (v-x) |
| 517 | ($pr$ v-x) |
| 518 | ($pr$ '": ") |
| 519 | (setq v-x (get v-x 'label)) |
| 520 | (cm-alst4 v-x))) |
| 521 | |
| 522 | ;--- cm-alst4 - v-x : s-expression |
| 523 | ; the given expression is exploded and printed as a string to the |
| 524 | ; assembler, this requires that each character be individually |
| 525 | ; noted and that the number of bytes on a line be limited. |
| 526 | ; |
| 527 | (def cm-alst4 |
| 528 | (lambda (v-x) |
| 529 | ($pr$ '".byte ") |
| 530 | (do ((l (explode v-x) (cdr l)) |
| 531 | (cnt 1 (add1 cnt))) |
| 532 | ((null l) ($pr$ 0) ($terpri)) |
| 533 | ($pr$ '\') |
| 534 | ($pr$ (car l)) |
| 535 | (cond ((greaterp cnt 13) ($terpri) ($pr$ '".byte ") (setq cnt 0)) |
| 536 | (t ($pr$ '\,)))))) |
| 537 | ;--- w-save |
| 538 | ; stack the values of w-ret and w-labs |
| 539 | ; |
| 540 | (def w-save |
| 541 | (lambda nil (setq w-save (cons `(,w-ret ,w-labs ,w-locs) w-save)))) |
| 542 | |
| 543 | ;--- w-unsave |
| 544 | ; restore the values of w-ret and w-labs, popping them |
| 545 | ; off the w-save stack |
| 546 | ; |
| 547 | (def w-unsave |
| 548 | (lambda nil (setq w-ret (caar w-save) |
| 549 | w-labs (cadar w-save) |
| 550 | w-locs (caddar w-save) |
| 551 | w-save (cdr w-save)))) |
| 552 | \f |
| 553 | |
| 554 | ;--- f-exp - v-e form to evaluate |
| 555 | ; - v-r location to place result in. |
| 556 | ; - v-t restof stuff (intermidiate forms) |
| 557 | ; |
| 558 | ; This is the real workhorse of the compiler. |
| 559 | ; |
| 560 | (def f-exp |
| 561 | (lambda (v-e v-r v-t) |
| 562 | (prog (v-f v-i v-tem) |
| 563 | begin (cond ; atoms |
| 564 | ((f-one v-e) |
| 565 | ; if the symbol has not been declared special and is |
| 566 | ; not a local variable, we declare it special. |
| 567 | (g-specialchk v-e) |
| 568 | (return (f-addi (list 'get v-r v-e) v-t))) |
| 569 | |
| 570 | ; lambda expressions, we do the correct thing. |
| 571 | ; should check for bad forms here rather than call |
| 572 | ; f-chkf |
| 573 | ((not (atom (setq v-f (car v-e)))) |
| 574 | (setq v-f (cmacroexpand v-f)) |
| 575 | ; must check if the expression changes to an atom |
| 576 | (cond ((atom v-f) |
| 577 | (setq v-e (cons v-f (cdr v-e))) |
| 578 | (go begin))) |
| 579 | |
| 580 | (cond ((eq 'lambda (car v-f)) |
| 581 | (return (f-lambexp v-e v-r v-t))) |
| 582 | ; this case is necessary to compile |
| 583 | ; ('add 1 2) which the interpreter will |
| 584 | ; handle and I guess we should too |
| 585 | ((eq 'quote (car v-f)) |
| 586 | (comp-warn "Bizzare function name " (or v-f) N) |
| 587 | (setq v-e (cons (cadr v-f) (cdr v-e))) |
| 588 | (go begin)) |
| 589 | (t (comp-err " Illegal expression: " |
| 590 | (or v-f) |
| 591 | N)))) |
| 592 | |
| 593 | ; macro expand and continue |
| 594 | ((and (or (setq v-e (cmacroexpand v-e)) t) |
| 595 | (cond ((or (atom v-e) |
| 596 | (not (atom (car v-e)))) |
| 597 | (go begin)) ; if reduce to atom |
| 598 | ; or lambda exp |
| 599 | (t (setq v-f (car v-e)))) |
| 600 | nil)) |
| 601 | |
| 602 | ; special functions |
| 603 | ((setq v-i (get v-f x-spf)) (go special)) |
| 604 | ((setq v-i (get v-f x-spfq)) |
| 605 | (put v-f x-spfq nil) |
| 606 | (go special)) |
| 607 | ((setq v-i (get v-f x-spfn)) (go special)) |
| 608 | ((setq v-i (get v-f x-spfh)) |
| 609 | (setq v-e (funcall v-i v-e)) |
| 610 | (go normal)) |
| 611 | |
| 612 | ; macro within compiler |
| 613 | ((setq v-i (get v-f 'x-spfm)) |
| 614 | (setq v-e (funcall v-i v-e)) |
| 615 | (go begin)) |
| 616 | |
| 617 | ; nlambbdas, we quote the args |
| 618 | ((isnlam v-f) |
| 619 | (setq v-e (list v-f (list 'quote (cdr v-e)))) |
| 620 | (go normal)) |
| 621 | |
| 622 | |
| 623 | ; cxr form where x is elt of {a d} |
| 624 | ((setq v-i (chain v-f)) |
| 625 | (setq v-t (f-addi |
| 626 | (list 'chain |
| 627 | v-r |
| 628 | (setq v-r (f-use (Gensym nil))) |
| 629 | v-i) |
| 630 | v-t)) |
| 631 | (setq v-e (cadr v-e)) ; calc expr to new v-r |
| 632 | (go begin)) |
| 633 | |
| 634 | ; if this is not the last form before a return, |
| 635 | ; we go to normal to do a function invocation |
| 636 | ; otherwise we look to see if tail merging is |
| 637 | ; possible. |
| 638 | ((not (eq (caar v-t) 'return)) (go normal)) |
| 639 | ((or (eq (setq v-i w-bv) t) |
| 640 | (not (equal v-f w-name))) (go normal)) |
| 641 | ((not (f-iter (cdr v-e) (reverse v-i))) (go normal)) ) |
| 642 | |
| 643 | ; do tail merging. |
| 644 | (setq v-t (f-addi '(repeat) v-t)) |
| 645 | (setq v-e (reverse (cdr v-e))) |
| 646 | iterate (cond ((null v-e) (return v-t)) |
| 647 | ((equal (car v-e) (car v-i)) (go next))) |
| 648 | (setq v-t (f-addi (list 'set |
| 649 | (setq v-r (f-reg 'set)) |
| 650 | (car v-i)) |
| 651 | v-t)) |
| 652 | (setq v-t (f-exp (car v-e) v-r v-t)) |
| 653 | next (setq v-e (cdr v-e)) |
| 654 | (setq v-i (cdr v-i)) |
| 655 | (go iterate) |
| 656 | |
| 657 | ; the function will be handled specially by the compiler |
| 658 | special (cond ((setq v-i (funcall v-i (cdr v-e) v-r v-t)) |
| 659 | (return v-i))) |
| 660 | |
| 661 | ; normal handling, call function. |
| 662 | ; if this is a system function, do it quickly |
| 663 | normal (cond ((setq v-i (get (car v-e) 'x-sysf)) ; system fcn |
| 664 | (setq v-t |
| 665 | (f-pusha (cdr v-e) |
| 666 | (Gensym nil) |
| 667 | (f-addi `(call ,(f-make v-r r-xv) |
| 668 | ,v-i |
| 669 | ,(length (cdr v-e))) |
| 670 | v-t)))) |
| 671 | (t (setq v-t |
| 672 | (f-pusha `((quote ,(car v-e)) ,@(cdr v-e)) |
| 673 | (Gensym nil) |
| 674 | (f-addi `(call ,(f-make v-r r-xv) |
| 675 | nil |
| 676 | ,(length v-e)) |
| 677 | v-t))))) |
| 678 | |
| 679 | (return v-t)))) |
| 680 | \f |
| 681 | ;--- g-specialchk - v-e : expression |
| 682 | ; if v-e is a symbol and not declared special and not a local variable |
| 683 | ; we complain and delare it special |
| 684 | ; v-e is returned. |
| 685 | ; |
| 686 | (def g-specialchk |
| 687 | (lambda (v-e) |
| 688 | (cond ((and (symbolp v-e) |
| 689 | (not (get v-e x-spec)) |
| 690 | (not (member v-e w-locs))) |
| 691 | (flag v-e x-spec) |
| 692 | (comp-warn (or v-e) " declared special by compiler"))) |
| 693 | v-e)) |
| 694 | |
| 695 | |
| 696 | ;--- f-lambexp - v-e : lambda expression: ((lambda (x y z) exp) a b c) |
| 697 | ; - v-r : weather where result should be placed |
| 698 | ; - v-t : tail |
| 699 | ; |
| 700 | ; This compiled a lambda expression. This is a very simple do-expression |
| 701 | ; with the difference that returns are not allowed from within it. |
| 702 | |
| 703 | (def f-lambexp |
| 704 | (lambda (v-e v-r v-t) |
| 705 | (f-pusha (cdr v-e) |
| 706 | (Gensym nil) |
| 707 | (f-lambbody (cdar v-e) v-r (length (cadar v-e)) v-t)))) |
| 708 | |
| 709 | ;--- f-lambbody - v-e : args + body of lambda ((a b c) exp1 exp2 ...) |
| 710 | ; - v-ags : number of args pushed for this lambda, it will |
| 711 | ; normally equal the length of (cadr v-e) but |
| 712 | ; in the case of the top level lambda expression |
| 713 | ; in a function it will be 0 |
| 714 | ; - v-r : psreg to place result in |
| 715 | ; - v-t : tail |
| 716 | ; We emit the intermediate expressions necessary to evaluate the |
| 717 | ; lambda body |
| 718 | ; |
| 719 | (def f-lambbody |
| 720 | (lambda (v-e v-r v-ags v-t) |
| 721 | (w-save) ; stack old values |
| 722 | (prog (w-ret w-labs tmp) |
| 723 | (setq tmp `((begin ,v-ags) |
| 724 | ,@(mapcar '(lambda (arg) (setq w-locs |
| 725 | (cons arg w-locs)) |
| 726 | `(bind ,arg)) |
| 727 | (car v-e)) |
| 728 | ,@(f-seq (cdr v-e) |
| 729 | v-r |
| 730 | `((end nil) |
| 731 | ,@v-t)))) |
| 732 | (w-unsave) |
| 733 | (return tmp)))) |
| 734 | |
| 735 | ;--- f-func - v-l : function args and body. |
| 736 | ; |
| 737 | ; result is: (entry type) ; type is lambda,lexpr, macro |
| 738 | ; or nlambda |
| 739 | ; ..body.. |
| 740 | ; |
| 741 | ; (fini) |
| 742 | ; |
| 743 | (def f-func |
| 744 | (lambda (v-l) |
| 745 | `((entry ,k-ftype) |
| 746 | ,@(f-lambbody v-l 'xv 0 '((fini)))))) |
| 747 | |
| 748 | |
| 749 | ;--- f-prog - v-l : args + prog body |
| 750 | ; - v-r : psreg to store result in |
| 751 | ; - v-t : tail |
| 752 | ; |
| 753 | (def f-prog |
| 754 | (lambda (v-l v-r v-t) |
| 755 | (w-save) |
| 756 | (prog (w-ret tmp retlb w-labs) |
| 757 | (setq tmp (length (car v-l)) ; number of locals |
| 758 | retlb (Gensym nil) ; label to leave prog |
| 759 | w-labs (Gensym nil) ; hang labels here |
| 760 | w-ret `(,v-r . (go ,retlb))) |
| 761 | |
| 762 | (setq tmp `((pushnil ,tmp) ; start out with nils |
| 763 | (begin ,tmp) ; declare variables |
| 764 | ,@(mapcar '(lambda (arg) (setq w-locs |
| 765 | (cons arg w-locs)) |
| 766 | `(bind ,arg)) |
| 767 | (car v-l)) ; bind locals |
| 768 | ,@(f-seqp (cdr v-l) (Gensym nil) |
| 769 | `((get ,v-r nil) |
| 770 | (end ,retlb) |
| 771 | ,@v-t)))) |
| 772 | (w-unsave) |
| 773 | (return tmp)))) |
| 774 | |
| 775 | |