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