1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PC:LAP-TO-ASM.SL 4% Title: LAP to assembler translator 5% Author: Eric Benson 6% Created: 13 August 1981 7% Modified: 15-Jan-85 11:00 (Brian Beach) 8% Status: Experimental 9% Mode: Lisp 10% Package: Compiler 11% 12% (c) Copyright 1983, Hewlett-Packard Company, see the file 13% HP_disclaimer at the root of the PSL file tree 14% 15% (c) Copyright 1982, University of Utah 16% 17% Redistribution and use in source and binary forms, with or without 18% modification, are permitted provided that the following conditions are met: 19% 20% * Redistributions of source code must retain the relevant copyright 21% notice, this list of conditions and the following disclaimer. 22% * Redistributions in binary form must reproduce the above copyright 23% notice, this list of conditions and the following disclaimer in the 24% documentation and/or other materials provided with the distribution. 25% 26% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 27% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 28% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 29% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 30% CONTRIBUTORS 31% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 32% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 33% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 34% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 35% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 36% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 37% POSSIBILITY OF SUCH DAMAGE. 38% 39%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 40% 41% Revisions: 42% 43% 20-Dec-86 (Leigh Stoller) 44% Wrapped printexpressionform* in a copy so that it ends up in the heap. 45% Cannot do destructive operations into bps if we want to move the 46% text/data boundry in unexec. 47 48(fluid '(semic* *comp *plap dfprint* charactersperword 49 addressingunitsperitem addressingunitsperfunctioncell 50 inputsymfile* outputsymfile* codeout* dataout* 51 initout* !; codefilenameformat* datafilenameformat* 52 initfilenameformat* modulename* uncompiledexpressions* 53 nextidnumber* orderedidlist* nilnumber* 54 *mainfound % Main entry point found /csp 55 *main % Compiling "main" module (MAIN.RED) /csp 56 *declarebeforeuse mainentrypointname* entrypoints* 57 locallabels* codeexternals* codeexporteds* 58 dataexternals* dataexporteds* 59 externaldeclarationformat* exporteddeclarationformat* 60 labelformat* fullwordformat* doublefloatformat* 61 reservedatablockformat* reservezeroblockformat* 62 undefinedfunctioncellinstructions* 63 definedfunctioncellformat* printexpressionform* 64 printexpressionformpointer* commentformat* 65 numericregisternames* expressioncount* asmopenparen* 66 asmcloseparen* tobecompiledexpressions* 67 fasl-preeval* 68 )) 69 70% Default values; set up if not already initialized. 71(when (null inputsymfile*) 72 (setq inputsymfile* "psl.sym")) 73 74(when (null outputsymfile*) 75 (setq outputsymfile* "psl.sym")) 76 77(when (null initfilenameformat*) 78 (setq initfilenameformat* "%w.init")) 79 80(de dfprintasm (u) 81 % Called by top-loop, dskin, dfprint to compile a single form. 82 (funcall dfprint* u)) 83 84%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 85% Special cases for ASMOUT: 86%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 87 88(put 'de 'asmpreeval 89 (function (lambda (u loadtime?) (fasl-define u 'expr loadtime?)))) 90(put 'df 'asmpreeval 91 (function (lambda (u loadtime?) (fasl-define u 'fexpr loadtime?)))) 92(put 'dm 'asmpreeval 93 (function (lambda (u loadtime?) (fasl-define u 'macro loadtime?)))) 94(put 'dn 'asmpreeval 95 (function (lambda (u loadtime?) (fasl-define u 'nexpr loadtime?)))) 96(put 'loadtime 'asmpreeval 97 (function (lambda (u loadtime?) (fasl-form (cadr u) T)))) 98(put 'startuptime 'asmpreeval 99 (function (lambda (u loadtime?) (saveforcompilation (cadr u))))) 100(put 'progn 'asmpreeval 101 (function (lambda (u loadtime?) 102 (foreach x in (cdr u) do (fasl-form x loadtime?))))) 103 104% do it now 105(de asmpreevalsetq (u loadtime?) 106 (let ((x (second u)) 107 (val (third u))) 108 (cond ((or (constantp val) (equal val t)) 109 (findidnumber x) 110 (put x 'initialvalue val) 111 nil) 112 ((null val) 113 (findidnumber x) 114 (remprop x 'initialvalue) 115 (flag (list x) 'nilinitialvalue) 116 nil) 117 ((eqcar val 'quote) 118 (findidnumber x) 119 (setq val (cadr val)) 120 (if (null val) 121 (progn (remprop x 'initialvalue) 122 (flag (list x) 'nilinitialvalue)) 123 (put x 'initialvalue val)) 124 nil) 125 ((or (and (idp val) (get val 'initialvalue)) 126 (flagp val 'nilinitialvalue)) 127 (if (setq val (get val 'initialvalue)) 128 (put x 'initialvalue val) 129 (flag (list x) 'nilinitialvalue))) 130 (t (saveuncompiledexpression u)) 131 ))) 132 133% just check simple cases, else return 134(put 'setq 'asmpreeval 'asmpreevalsetq) 135 136(de asmpreevalputd (u loadtime?) 137 (saveuncompiledexpression (checkforeasysharedentrypoints u))) 138 139(de checkforeasysharedentrypoints (u) 140 % 141 % looking for (PUTD (QUOTE name1) xxxx (CDR (GETD (QUOTE name2)))) 142 % 143 (prog (nu nam exp) 144 (setq nu (cdr u)) 145 (setq nam (car nu)) 146 (if (equal (car nam) 'quote) 147 (setq nam (cadr nam)) 148 (return u)) 149 (setq nu (cdr nu)) 150 (setq exp (cadr nu)) 151 (unless (equal (car exp) 'cdr) 152 (return u)) 153 (setq exp (cadr exp)) 154 (unless (equal (car exp) 'getd) 155 (return u)) 156 (setq exp (cadr exp)) 157 (unless (equal (car exp) 'quote) 158 (return u)) 159 (setq exp (cadr exp)) 160 (findidnumber nam) 161 (put nam 'entrypoint (findentrypoint exp)) 162 (unless (equal (car nu) ''expr) 163 (return (list 'put ''type (car nu)))) 164 (return nil))) 165 166(put 'putd 'asmpreeval 'asmpreevalputd) 167 168(de asmpreevalfluidandglobal (u loadtime?) 169 (when (eqcar (cadr u) 'quote) 170 (flag (cadr (cadr u)) 'nilinitialvalue)) 171 (saveuncompiledexpression u)) 172 173(put 'fluid 'asmpreeval 'asmpreevalfluidandglobal) 174 175(put 'global 'asmpreeval 'asmpreevalfluidandglobal) 176 177(de asmpreevallap (u loadtime?) 178 (if (eqcar (cadr u) 'quote) 179 (asmoutlap (cadr (cadr u))) 180 (saveuncompiledexpression u))) 181 182(put 'lap 'asmpreeval 'asmpreevallap) 183 184%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 185% ASMOUT and friends: 186%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 187 188(de saveuncompiledexpression (u) 189 (when (pairp u) 190 (prog (oldout) 191 (setq oldout (wrs initout*)) 192 (print u) 193 (wrs oldout)))) 194 195(setq tobecompiledexpressions* (cons nil nil)) 196 197(de saveforcompilation (u) 198 (cond ((or (atom u) (member u (car tobecompiledexpressions*))) nil) 199 ((equal (car u) 'progn) 200 (foreach x in (cdr u) do (saveforcompilation x))) 201 (t (tconc tobecompiledexpressions* u)))) 202 203(de asmout (fil) 204 (prin2t "ASMOUT: IN files; or type in expressions") 205 (prin2t "When all done execute ASMEND;") 206 (setq modulename* fil) 207 208 % Open the CODE output file, setting the line length large, and adding the header. 209 210 (setq codeout* (open (bldmsg codefilenameformat* modulename*) 'output)) 211 (let ((oldout (wrs codeout*))) 212 (linelength 1000) 213 (wrs oldout) 214 ) 215 (codefileheader) 216 217 % Open the DATA output file, setting the line length large, and adding the header. 218 219 (setq dataout* (open (bldmsg datafilenameformat* modulename*) 'output)) 220 (let ((oldout (wrs dataout*))) 221 (linelength 1000) 222 (wrs oldout) 223 ) 224 (datafileheader) 225 226 % Open the INIT output file. 227 228 (setq initout* (open (bldmsg initfilenameformat* modulename*) 'output)) 229 230 (readsymfile) 231 (setq dfprint* 'dfprintfasl) 232 (remd 'oldlap) 233 (copyd 'oldlap 'lap) 234 (remd 'lap) 235 (copyd 'lap 'asmoutlap) 236 (setq *defn t) 237 (setf fasl-preeval* 'asmpreeval) 238 (setf *constants-for-compiler* t) 239 (setq semic* '!$) % to turn echo off for IN 240 (when (or (string-equal modulename* "main") *main) 241 (setq *main t) 242 )) 243 244(de asmend () 245 (if *mainfound 246 (progn (compileuncompiledexpressions) 247 (initializesymboltable)) 248 (writesymfile)) 249 (codefiletrailer) 250 (close codeout*) 251 (datafiletrailer) 252 (close dataout*) 253 (close initout*) 254 (remd 'lap) 255 (copyd 'lap 'oldlap) 256 (setq dfprint* nil) 257 (setq *defn nil) 258 (setf *constants-for-compiler* nil) 259 ) 260 261(flag '(asmend) 'ignore) 262 263(de compileuncompiledexpressions () 264 (dfprintasm (list 'de 'initcode 'nil 265 (cons 'progn (car tobecompiledexpressions*))))) 266 267(de readsymfile () 268 (lapin inputsymfile*)) 269 270(de writesymfile () 271 (prog (newout oldout) 272 (setq oldout (wrs (setq newout (open outputsymfile* 'output)))) 273 (print (list 'saveforcompilation 274 (mkquote 275 (cons 'progn (car tobecompiledexpressions*))))) 276 (saveidlist) 277 (setqprint 'nextidnumber*) 278 (setqprint 'stringgensym*) 279 (mapobl (function putprintentryandsym)) 280 (wrs oldout) 281 (close newout))) 282 283(de saveidlist () 284 (print (list 'setq 'orderedidlist* (mkquote (car orderedidlist*)))) 285 (print '(setq orderedidlist* 286 (cons orderedidlist* (lastpair orderedidlist*))))) 287 288(de setqprint (u) 289 (print (list 'setq u (mkquote (eval u))))) 290 291(de putprint (x y z) 292 (print (list 'put (mkquote x) (mkquote y) (mkquote z)))) 293 294% putprintentryandsym contols what is rewritten into the symbol file 295% from the current propertylists. 296(de putprintentryandsym (x) 297 (prog (y) 298 (when (setq y (get x 'entrypoint)) 299 (putprint x 'entrypoint y)) 300 (when (setq y (get x 'symbol)) 301 (putprint x 'symbol y)) 302 (when (setq y (get x 'idnumber)) 303 (putprint x 'idnumber y)) 304 (when (flagp x 'internalsymbol) 305 (print (list 'flag1 (mkquote x) ''internalsymbol))) 306 (when (flagp x 'exportedsymbol) 307 (print (list 'flag1 (mkquote x) ''exportedsymbol))) 308 (when (flagp x 'externalsymbol) 309 (print (list 'flag1 (mkquote x) ''externalsymbol))) 310 (cond ((setq y (get x 'initialvalue)) (putprint x 'initialvalue y)) 311 ((flagp x 'nilinitialvalue) 312 (print (list 'flag (mkquote (list x)) ''nilinitialvalue)))) 313)) 314 315(de findidnumber (u) 316 (prog (i) 317 (return (cond ((leq (setq i (id2int u)) 128) i) 318 ((setq i (get u 'idnumber)) i) 319 (t (put u 'idnumber (setq i nextidnumber*)) 320 (setq orderedidlist* (tconc orderedidlist* u)) 321 (setq nextidnumber* (plus nextidnumber* 1)) i))))) 322 323(setq orderedidlist* (cons nil nil)) 324 325(setq nextidnumber* 256) 326 327(de initializesymboltable () 328 (let ((maxsymbol (compiler-constant 'maxsymbols)) olddataout) 329 (when (lessp maxsymbol nextidnumber*) 330 (errorprintf "*** MaxSymbols %r is too small; at least %r are needed" 331 maxsymbol nextidnumber*) 332 (setq maxsymbol (plus nextidnumber* 100))) 333 (flag '(nil) 'nilinitialvalue) 334 (put 't 'initialvalue 't) 335 (setq nilnumber* (compileconstant nil)) 336 (setq olddataout dataout*) 337 (setq dataout* (open "S_VA_FN.asm" 'output)) 338 (dataalignfullword) 339 (initializesymval) 340 (datareserveblock (plus (difference maxsymbol nextidnumber*) 1)) 341 (initializesymfnc) 342 (datareservefunctioncellblock 343 (plus (difference maxsymbol nextidnumber*) 1)) 344 (close dataout*) 345 (setq dataout* (open "S_PR_NA.asm" 'output)) 346 (initializesymprp) 347 (datareserveblock (plus (difference maxsymbol nextidnumber*) 1)) 348 (initializesymnam) 349 (datareserveblock (plus (difference maxsymbol nextidnumber*) 1)) 350 (dataprintf " DD %w DUP (?) %n" (times2 4 maxsymbol)) 351 (close dataout*) 352 (setq dataout* olddataout) 353% (initializesymget) % SYMGET feature 354% (datareserveblock (plus (difference maxsymbol nextidnumber*) 1)) 355% (dataalignfullword) 356% (dataprintgloballabel (findgloballabel 'nextsymbol)) 357% (dataprintfullword nextidnumber*) 358 )) 359 360(de initializesymprp () 361 % init prop lists 362 (dataprintgloballabel (findgloballabel 'symprp)) 363 (for (from i 0 128 1) (do (initsymprp1 (int2id i)))) 364 (for (from i 129 255 1) (do (initsymprp1 (int2id 0)))) 365 (foreach x in (car orderedidlist*) do (initsymprp1 x))) 366 367(de initsymprp1 (x) (dataprintfullword nilnumber*)) 368 369(de auxaux (i) 370 (prog (j) 371 (setq j (gtstr 0)) 372 (putstrbyt j 0 i) 373 (return (mkstr j)) 374 )) 375 376(de initializesymnam (maxsymbol) 377 (dataprintgloballabel (findgloballabel 'symnam)) 378 (for (from i 0 128 1) 379 (do (dataprintfullword (compileconstant (id2string (int2id i)))))) 380 (for (from i 129 255 1) 381 (do (dataprintfullword (compileconstant (auxaux i))))) 382 (for (in idname (car orderedidlist*)) 383 (do (dataprintfullword (compileconstant (id2string idname)))) 384 )) 385 386(de initializesymget () 387 (dataprintgloballabel (findgloballabel 'symget)) 388 (for (from i 0 255 1) (do 389 (dataprintfullword nilnumber*))) 390 (foreach x in (car orderedidlist*) do 391 (dataprintfullword nilnumber*)) 392 ) 393 394(de initializesymval () 395 (dataprintgloballabel (findgloballabel 'symval)) 396 (for (from i 0 128 1) (do (initsymval1 (int2id i)))) 397 (for (from i 129 255 1) (do 398 (dataprintfullword 399 (list 'mkitem (compiler-constant 'unbound-tag) i)))) 400 (foreach x in (car orderedidlist*) do (initsymval1 x))) 401 402(de initsymval1 (x) 403 (prog (val) 404% now decide what to plant in value cell at compiletime. 405 (return (dataprintfullword 406 (cond 407 ((eq x 'nextsymbol) nextidnumber*) 408% print the corresponding symbol for the valuecell with label, and external declaration. 409 ((flagp x 'externalsymbol) 410 (setq val (get x 'symbol)) 411% (datadeclareexternal val) 412 val) 413% print the corresponding symbol for the valuecell with label, and exported declaration. 414 ((flagp x 'exportedsymbol) 415 (setq val (get x 'symbol)) 416 (datadeclareexported val) 417 (dataprintlabel val) 418 (list 'mkitem (compiler-constant 'unbound-tag) 419 (findidnumber x))) 420% print internal references for symnam, symfnc, symval, symprp. 421 ((flagp x 'internalsymbol) 422 (setq val (get x 'symbol)) 423 val) 424% print the initial value. 425 ((setq val (get x 'initialvalue)) 426 (compileconstant val)) 427% print the value of nil. 428 ((flagp x 'nilinitialvalue) nilnumber*) 429% print the unbound variable value. 430 (t 431 (list 'mkitem (compiler-constant 'unbound-tag) 432 (findidnumber x)))))))) 433 434(de initializesymfnc () 435 (dataprintgloballabel (findgloballabel 'symfnc)) 436 (for (from i 0 255 1) (do (initsymfnc1 (int2id i)))) 437 (foreach x in (car orderedidlist*) do (initsymfnc1 x))) 438 439(de initsymfnc1 (x) 440 (prog (ep) 441 (setq ep (get x 'entrypoint)) 442 (if (null ep) 443 (dataprintundefinedfunctioncell) 444 (dataprintdefinedfunctioncell ep)))) 445 446(de asmoutlap (u) 447 (prog (locallabels* oldout) 448 (setq u (pass1lap u)) 449 % Expand cmacros, quoted expressions 450 (codeblockheader) 451 (setq oldout (wrs codeout*)) 452 (foreach x in u do (asmoutlap1 x)) 453 (wrs oldout) 454 (codeblocktrailer))) 455 456(de asmoutlap1 (x) 457 (prog (fn) 458 (return (cond ((stringp x) (printlabel x)) 459 ((atom x) (printlabel (findlocallabel x))) 460 ((setq fn (get (car x) 'asmpseudoop)) 461 (apply fn (list x))) 462 (t 463 % instruction output form is: 464 % "space" <opcode> [ "space" <operand> { "comma" <operand> } ] "newline" 465 466 (progn (prin2 '! ) 467 % Space 468 (when (wgreaterp (length x) 2) 469 (setq x (invertsequence x))) 470 (printopcode (car x)) 471 (prin2 " ") % space 472 (when (and (eq (car x) 'mov) 473 (pairp (cadr x)) 474 (memq(caadr x) '($fluid $global fluid global))) 475 (prin2 "ds:")) 476 (setq x (cdr x)) 477 (unless (null x) 478 (printoperand (car x)) 479 (foreach u in (cdr x) do 480 (progn (prin2 '!,) 481 % COMMA 482 (printoperand u)))) 483 (prin2 (int2id 13)) 484 (prin2 !$eol!$))))))) 485 486% NEWLINE 487(de invertsequence (x) 488 (prog (y) 489 (setq y (cons (car x) (last x))) 490 (setq x (reverse (cdr (reverse (cdr x))))) 491 (return (append y x)))) 492 493(put '*entry 'asmpseudoop 'asmprintentry) 494 495(de asmprintentry (x) 496 (prog (y) 497 (printcomment x) 498 (setq x (cadr x)) 499 (setq y (findentrypoint x)) 500 (unless (flagp x 'internalfunction) 501 (findidnumber x)) 502 (if (eq x mainentrypointname*) 503 (progn (setq *mainfound t) 504 (specialactionformainentrypoint)) 505 (codedeclareexporteduse y)))) 506 507(de codedeclareexporteduse (y) 508 (if *declarebeforeuse 509 (progn (codedeclareexported y) 510 (printlabel y)) 511 (progn (printlabel y) 512 (codedeclareexported y)))) 513 514(de findentrypoint (x) 515 (cond ((get x 'entrypoint) (get x 'entrypoint)) 516 ((and (asmsymbolp x) 517 (not (get x 'symbol)) 518 (not (flagp x 'foreignfunction))) 519 (put x 'entrypoint x) 520 x) 521 (t 522 (let ((name (stringgensym))) 523 (put x 'entrypoint name) 524 name)) 525 )) 526 527(de asmpseudoprintfloat (x) 528 (printf doublefloatformat* (cadr x))) 529 530(put 'float 'asmpseudoop 'asmpseudoprintfloat) 531 532(de asmpseudoprintfullword (x) 533 (foreach y in (cdr x) do (printfullword y))) 534 535(put 'fullword 'asmpseudoop 'asmpseudoprintfullword) 536 537(de asmpseudoprintindword (x) 538 (foreach y in (cdr x) do (printindword y))) 539 540(put 'indword 'asmpseudoop 'asmpseudoprintindword) 541 542(de asmpseudoprintbyte (x) 543 (printbytelist (cdr x))) 544 545(put 'byte 'asmpseudoop 'asmpseudoprintbyte) 546 547(de asmpseudoprinthalfword (x) 548 (printhalfwordlist (cdr x))) 549 550(put 'halfword 'asmpseudoop 'asmpseudoprinthalfword) 551 552(de asmpseudoprintstring (x) 553 (printstring (cadr x))) 554 555(put 'string 'asmpseudoop 'asmpseudoprintstring) 556 557(de printoperand (x) 558 (cond ((stringp x) (prin2 x)) 559 ((numberp x) (printnumericoperand x)) 560 ((idp x) (prin2 (findlabel x))) 561 (t (prog (hd fn) 562 (setq hd (car x)) 563 (cond ((setq fn (get hd 'operandprintfunction)) 564 (apply fn (list x))) 565 ((and (setq fn (getd hd)) (equal (car fn) 'macro)) 566 (printoperand (apply (cdr fn) (list x)))) 567 ((setq fn (wconstevaluable x)) (printoperand fn)) 568 (t (printexpression x))))))) 569 570(put 'reg 'operandprintfunction 'printregister) 571 572(de printregister (x) 573 (prog (nam) 574 (setq x (cadr x)) 575 (cond ((stringp x) (prin2 x)) 576 ((numberp x) (prin2 (getv numericregisternames* x))) 577 ((setq nam (registernamep x)) (prin2 nam)) 578 (t (errorprintf "***** Unknown register %r" x) (prin2 x))))) 579 580(de registernamep (x) 581 (get x 'registername)) 582 583(de asmentry (x) 584 (printexpression 585 (list 'plus2 586 'symfnc 587 (list 'times2 588 (compiler-constant 'addressingunitsperfunctioncell) 589 (list 'idloc (cadr x)))))) 590 591(put 'entry 'operandprintfunction 'asmentry) 592 593(put 'entry 'asmexpressionfunction 'asmentry) 594 595(de asminternalentry (x) 596 (prin2 (findentrypoint (cadr x)))) 597 598(put 'internalentry 'operandprintfunction 'asminternalentry) 599 600(put 'internalentry 'asmexpressionfunction 'asminternalentry) 601 602(dm extrareg (u) 603 (list 'plus2 '(fluid argumentblock) 604 (times (difference (cadr u) (plus lastactualreg!& 1)) 605 (compiler-constant 'addressingunitsperitem)))) 606 607(de asmsyslispvarsprint (x) 608 (prin2 (findgloballabel (cadr x)))) 609 610(de asmprintvaluecell (x) 611 (printexpression (list 'plus2 'symval 612 (list 'times (compiler-constant 'addressingunitsperitem) 613 (list 'idloc (cadr x)))))) 614 615(deflist '((fluid asmprintvaluecell) (!$fluid asmprintvaluecell) 616 (global asmprintvaluecell) (!$global asmprintvaluecell)) 617 'operandprintfunction) 618 619(de lookuporaddasmsymbol (u) 620 (prog (x) 621 (unless (setq x (get u 'symbol)) 622 (setq x (addasmsymbol u))) 623 (return x))) 624 625(de addasmsymbol (u) 626 (let ((x (if (and (asmsymbolp u) 627 (not (get u 'entrypoint)) 628 (not (flagp u 'foreignfunction))) 629 u 630 (stringgensym)))) 631 (put u 'symbol x) 632 (return x))) 633 634(de dataprintvar (name init) 635 (prog (oldout) 636 (dataprintlabel name) 637 (setq oldout (wrs dataout*)) 638 (printfullword init) 639 (wrs oldout))) 640 641(de dataprintblock (name siz typ) 642 (if (equal typ 'wstring) 643 (setq siz 644 (list 'quotient (list 'plus2 siz (plus (compiler-constant 'charactersperword) 1)) 645 (compiler-constant 'charactersperword))) 646 (setq siz (list 'plus2 siz 1))) 647 (datareservezeroblock name siz)) 648 649(de dataprintlist (nam init typ) 650 (prog (oldout) 651 (dataprintlabel nam) 652 (setq oldout (wrs dataout*)) 653 (cond 654 ((stringp init) 655 (prog (s) 656 (setq s (size init)) 657 (for (from i 0 s 1) 658 (do (printfullword (indx init i)))))) 659 (t (foreach x in init do (printfullword x)))) 660 (wrs oldout))) 661 662(de dataprintgloballabel (x) 663 (when *declarebeforeuse 664 (datadeclareexported x)) 665 (dataprintlabel x) 666 (unless *declarebeforeuse 667 (datadeclareexported x)) 668% (codedeclareexternal x)) 669) 670 671(de datadeclareexternal (x) 672 (unless (or (member x dataexternals*) (member x dataexporteds*)) 673 (setq dataexternals* (cons x dataexternals*)) 674 (dataprintf externaldeclarationformat* x x))) 675 676(de codedeclareexternal (x) 677 (unless (or (member x codeexternals*) (member x codeexporteds*)) 678 (setq codeexternals* (cons x codeexternals*)) 679 (codeprintf externaldeclarationformat* x x))) 680 681(de datadeclareexported (x) 682 (when (or (member x dataexternals*) (member x dataexporteds*)) 683 (errorprintf "***** %r multiply defined" x)) 684 (setq dataexporteds* (cons x dataexporteds*)) 685 (dataprintf exporteddeclarationformat* x x)) 686 687(de codedeclareexported (x) 688 (when (or (member x codeexternals*) (member x codeexporteds*)) 689 (errorprintf "***** %r multiply defined" x)) 690 (setq codeexporteds* (cons x codeexporteds*)) 691 (codeprintf exporteddeclarationformat* x x)) 692 693(de printlabel (x) 694 (printf labelformat* x x)) 695 696(de dataprintlabel (x) 697 (dataprintf datalabelformat* x x)) 698 699(de codeprintlabel (x) 700 (codeprintf labelformat* x x)) 701 702(de printcomment (x) 703 (printf commentformat* x)) 704 705%% Okay to do destructive ops to save consing as long as the replaca's are 706%% done on the heap, not bps. That way we can unexec over them. /LBS 707 708%(setq printexpressionform* (list 'printexpression (mkquote nil))) 709(setq printexpressionform* (totalcopy (list 'printexpression (mkquote nil)))) 710 711(setq printexpressionformpointer* (cdadr printexpressionform*)) 712 713% Save some consing 714% instead of list('PrintExpression, MkQuote X), reuse the same list structure 715 716(de printfullword (x) 717 (rplaca printexpressionformpointer* x) 718 (printf fullwordformat* printexpressionform*)) 719 720(de printindword (x) 721 (rplaca printexpressionformpointer!* x) 722 (printf indwordformat!* printexpressionform!*)) 723 724(de dataprintfullword (x) 725 (rplaca printexpressionformpointer* x) 726 (dataprintf fullwordformat* printexpressionform*)) 727 728(de codeprintfullword (x) 729 (rplaca printexpressionformpointer* x) 730 (codeprintf fullwordformat* printexpressionform*)) 731 732(de datareservezeroblock (nam x) 733 (rplaca printexpressionformpointer* 734 (list 'times2 (compiler-constant 'addressingunitsperitem) x)) 735 (dataprintf reservezeroblockformat* nam printexpressionform*)) 736 737(de datareserveblock (x) 738 (rplaca printexpressionformpointer* 739 (list 'times2 (compiler-constant 'addressingunitsperitem) x)) 740 (dataprintf reservedatablockformat* printexpressionform*)) 741 742(de datareservefunctioncellblock (x) 743 (rplaca printexpressionformpointer* 744 (list 'times2 (compiler-constant 'addressingunitsperfunctioncell) x)) 745 (dataprintf reservedatablockformat* printexpressionform*)) 746 747(de dataprintundefinedfunctioncell () 748 (prog (oldout) 749 (setq oldout (wrs dataout*)) 750 (foreach x in undefinedfunctioncellinstructions* do 751 (asmoutlap1 x)) 752 (wrs oldout))) 753 754(de dataprintdefinedfunctioncell (x) 755 %(datadeclareexternal x) 756 (dataprintf definedfunctioncellformat* x x)) 757 758% in case it's needed twice 759(de dataprintbytelist (x) 760 (prog (oldout) 761 (setq oldout (wrs dataout*)) 762 (printbytelist x) 763 (wrs oldout))) 764 765(de dataprintexpression (x) 766 (prog (oldout) 767 (setq oldout (wrs dataout*)) 768 (printexpression x) 769 (wrs oldout))) 770 771(de codeprintexpression (x) 772 (prog (oldout) 773 (setq oldout (wrs codeout*)) 774 (printexpression x) 775 (wrs oldout))) 776 777(setq expressioncount* -1) 778 779(de printexpression (x) 780 ((lambda (expressioncount*) 781 (prog (hd tl fn) 782 (setq x (resolvewconstexpression x)) 783 (cond ((or (numberp x) (stringp x)) (prin2 x)) 784 ((idp x) (prin2 (findlabel x))) 785 ((atom x) 786 (errorprintf "***** Oddity in expression %r" x) 787 (prin2 x)) 788 (t 789 (setq hd (car x)) (setq tl (cdr x)) 790 (cond 791 ((setq fn (get hd 'binaryasmop)) 792 (when (greaterp expressioncount* 0) 793 (prin2 asmopenparen*)) 794 (printexpression (car tl)) (prin2 fn) 795 (printexpression (cadr tl)) 796 (when (greaterp expressioncount* 0) 797 (prin2 asmcloseparen*))) 798 ((setq fn (get hd 'unaryasmop)) (prin2 fn) 799 (printexpression (car tl))) 800 ((setq fn (get hd 'asmexpressionformat)) 801 (apply 'printf 802 (cons fn 803 (foreach y in tl collect 804 (list 'printexpression 805 (mkquote y)))))) 806 ((and (setq fn (getd hd)) 807 (equal (car fn) 'macro)) 808 (printexpression (apply (cdr fn) (list x)))) 809 ((setq fn (get hd 'asmexpressionfunction)) 810 (apply fn (list x))) 811 (t 812 (errorprintf "***** Unknown expression %r" 813 x) 814 (printf "*** Expression error %r ***" x))))))) 815 (plus expressioncount* 1))) 816 817(deflist '((plus2 !+) (wplus2 !+) (difference !-) (wdifference !-) 818 (times2 *) (wtimes2 *) (quotient !/) (wquotient !/)) 819 'binaryasmop) 820 821(deflist '((minus !-) (wminus !-)) 'unaryasmop) 822 823(de compileconstant (x) 824 (setq x (buildconstant x)) 825 (if (null (cdr x)) 826 (car x) 827 (progn (when *declarebeforeuse 828 (codedeclareexported (cadr x))) 829 (CODEPRINTF " align 4%n") % 29.9.93 830 (asmoutlap (cdr x)) 831% (datadeclareexternal (cadr x)) 832 (unless *declarebeforeuse 833 (codedeclareexported (cadr x))) 834 (car x)))) 835 836(de dataprintstring (x) 837 (prog (oldout) 838 (setq oldout (wrs dataout*)) 839 (printstring x) 840 (wrs oldout))) 841 842(de findlabel (x) 843 (prog (y) 844 (return (cond ((setq y (atsoc x locallabels*)) (cdr y)) 845 ((setq y (get x 'symbol)) y) 846 (t (findlocallabel x)))))) 847 848(de findlocallabel (x) 849 (prog (y) 850 (return (if (setq y (atsoc x locallabels*)) 851 (cdr y) 852 (progn (setq locallabels* 853 (cons (cons x (setq y (stringgensym))) 854 locallabels*)) 855 y))))) 856 857(de findgloballabel (x) 858 (or (get x 'symbol) (errorprintf "***** Undefined symbol %r" x))) 859 860(de codeprintf (fmt a1 a2 a3 a4) 861 (prog (oldout) 862 (setq oldout (wrs codeout*)) 863 (printf fmt a1 a2 a3 a4) 864 (wrs oldout))) 865 866(de dataprintf (fmt a1 a2 a3 a4) 867 (prog (oldout) 868 (setq oldout (wrs dataout*)) 869 (printf fmt a1 a2 a3 a4) 870 (wrs oldout))) 871 872% Kludge of the year, just to avoid having IDLOC defined during compilation 873(compiletime 874 (fluid '(macro))) 875 876(setq macro 'macro) 877 878(putd 'idloc macro (function (lambda (x) 879 (findidnumber (cadr x))))) 880(put 'declare-aux-1 'asmpreeval 'eval) 881 882(dm declare-kernel-structure (u) 883 (list 'declare-aux-1 (list 'quote (cdr u)))) 884 885(df declare-aux-1 (u) 886 (prog (olddataout) 887 (setq olddataout dataout*) 888 (setq dataout* (open "KSTRUCTS.asm" 'output)) 889 (foreach x in (cadar u) do 890 (declare-aux-2 (car x) (cadr x) )) 891 (close dataout*) 892 (setq dataout* olddataout))) 893 894(flag '(declare-aux-1) 'ignore) 895 896(de declare-aux-2 (name upperbound) 897 (findidnumber name) % generate an ID it doesn't exist. 898 (put name 'symbol name) % flag as a fluid variable. 899 (put name 'type 'fluid) % flag as a fluid variable. 900 (flag1 name 'externalsymbol) % flag as initial symbol value. 901 (when *declarebeforeuse (datadeclareexported name)) 902% (dataalignfullword) 903 (setq upperbound (list 'plus2 upperbound 1)) 904 (dataprintf " ALIGN 4%n") 905 (datareservezeroblock name upperbound) 906 (unless *declarebeforeuse (datadeclareexported name)) 907% (codedeclareexternal name) 908) 909 910 911 912