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