1;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2;; All rights reserved. 3;; 4;; Redistribution and use in source and binary forms, with or without 5;; modification, are permitted provided that the following conditions are 6;; met: 7;; 8;; - Redistributions of source code must retain the above copyright 9;; notice, this list of conditions and the following disclaimer. 10;; 11;; - Redistributions in binary form must reproduce the above copyright 12;; notice, this list of conditions and the following disclaimer in 13;; the documentation and/or other materials provided with the 14;; distribution. 15;; 16;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17;; names of its contributors may be used to endorse or promote products 18;; derived from this software without specific prior written permission. 19;; 20;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32;;; PURPOSE: 33;;; Provide generally useful macros and functions for MetaLanguage 34;;; and Boot code. Contents are organized along Common Lisp datatype 35;;; lines, with sections numbered to match the section headings of the 36;;; Common Lisp Reference Manual, by Guy Steele, Digital Press, 1984, 37;;; Digital Press Order Number EY-00031-DP. This way you can 38;;; look up the corresponding section in the manual and see if 39;;; there isn't a cleaner and non-VM-specific way of doing things. 40 41(provide 'Boot) 42 43(in-package "BOOT") 44 45; moved from bootfuns.lisp 46 47; Provide forward references to Boot Code for functions to be at 48; defined at the boot level, but which must be accessible 49; not defined at lower levels. 50 51(defmacro def-boot-var (p where) `(defparameter ,p nil ,where)) 52 53(defmacro def-boot-val (p val where) `(defparameter ,p ,val ,where)) 54 55(def-boot-val |$timerTicksPerSecond| INTERNAL-TIME-UNITS-PER-SECOND 56 "scale for get_run_time") 57(def-boot-val $boxString 58 (concatenate 'string (list (code-char #x1d) (code-char #xe2))) 59 "this string of 2 chars displays as a box") 60(def-boot-val |$quadSymbol| $boxString "displays an APL quad") 61(def-boot-val $escapeString (string (code-char 27)) 62 "string for single escape character") 63(def-boot-val |$boldString| (concatenate 'string $escapeString "[1m") 64 "switch into bold font") 65(def-boot-val |$normalString| (concatenate 'string $escapeString "[0;10m") 66 "switch back into normal font") 67(def-boot-val |$BreakMode| '|query| "error.boot") 68 69 70(def-boot-var |$compUniquelyIfTrue| "Compiler>Compiler.boot") 71(def-boot-val |$currentLine| "" "current input line for history") 72 73(def-boot-var |$exitMode| "???") 74(def-boot-var |$exitModeStack| "???") 75 76(def-boot-var |$fromSpadTrace| "Interpreter>Trace.boot") 77 78(def-boot-val |$genSDVar| 0 "counter for genSomeVariable" ) 79 80(def-boot-var |$insideCapsuleFunctionIfTrue| "???") 81(def-boot-var |$insideCategoryIfTrue| "???") 82(def-boot-var |$insideFunctorIfTrue| "???") 83(def-boot-var |$insideWhereIfTrue| "???") 84 85(def-boot-var |$leaveLevelStack| "???") 86(def-boot-var |$libFile| "Compiler>LispLib.boot") 87(def-boot-val $LISPLIB nil "whether to produce a lisplib or not") 88(def-boot-var |$lisplibForm| "Compiler>LispLib.boot") 89(def-boot-var |$lisplibKind| "Compiler>LispLib.boot") 90(def-boot-var |$lisplibModemapAlist| "Compiler>LispLib.boot") 91(def-boot-var |$lisplibModemap| "Compiler>LispLib.boot") 92(def-boot-var |$lisplibOperationAlist| "Compiler>LispLib.boot") 93 94(def-boot-var |$mapSubNameAlist| "Interpreter>Trace.boot") 95(def-boot-var |$mathTrace| "Interpreter>Trace.boot") 96(def-boot-var |$mathTraceList| "Controls mathprint output for )trace.") 97 98(def-boot-var |$postStack| "???") 99(def-boot-var |$previousTime| "???") 100(def-boot-val |$printLoadMsgs| nil "Interpreter>SetVarT.boot") 101(def-boot-var |$reportBottomUpFlag| "Interpreter>SetVarT.boot") 102(def-boot-var |$returnMode| "???") 103(def-boot-var |$semanticErrorStack| "???") 104(def-boot-val |$SetFunctions| nil "checked in SetFunctionSlots") 105 106(def-boot-var |$topOp| "See displayPreCompilationErrors") 107(def-boot-var |$tracedSpadModemap| "Interpreter>Trace.boot") 108(def-boot-var |$traceletFunctions| "???") 109 110(def-boot-var |$warningStack| "???") 111(def-boot-val |$whereList| () "referenced in format boot formDecl2String") 112 113(def-boot-val |$inputPromptType| '|step| "checked in MKPROMPT") 114(def-boot-val |$IOindex| 0 "step counter") 115 116; End of moved fragment 117 118; 5 PROGRAM STRUCTURE 119 120; 5.3.2 Declaring Global Variables and Named Constants 121 122(defun |functionp| (fn) 123 (if (identp fn) (and (fboundp fn) (not (macro-function fn))) (functionp fn))) 124(defun |macrop| (fn) (and (identp fn) (macro-function fn))) 125 126; 6 PREDICATES 127 128; Ordering 129 130(DEFUN ?ORDER (U V) 131 "Multiple-type ordering relation." 132;;; Result negated compared to LEXGREATERP and GGREATERP 133;;; Order of types: nil number symbol string vector cons" 134 (COND ((NULL U)) 135 ((NULL V) NIL) 136 ((ATOM U) 137 (if (ATOM V) 138 (COND ((NUMBERP U) (if (NUMBERP V) (> V U) T)) 139 ((NUMBERP V) NIL) 140 ((IDENTP U) (AND (IDENTP V) (string> (SYMBOL-NAME V) (SYMBOL-NAME U)))) 141 ((IDENTP V) NIL) 142 ((STRINGP U) (AND (STRINGP V) (string> V U))) 143 ((STRINGP V) NIL) 144 ((AND (VECP U) (VECP V)) 145 (AND (> (SIZE V) (SIZE U)) 146 (DO ((I 0 (1+ I))) 147 ((> I (MAXINDEX U)) 'T) 148 (COND ((NOT (EQUAL (ELT U I) (ELT V I))) 149 (RETURN (?ORDER (ELT U I) (ELT V I)))))))) 150 ((croak "Do not understand"))) 151 T)) 152 ((ATOM V) NIL) 153 ((EQUAL U V)) 154 ((EQUAL (CAR U) (CAR V)) 155 (?ORDER (CDR U) (CDR V))) 156 ((?ORDER (CAR U) (CAR V))) 157)) 158 159(DEFUN LEXGREATERP (COMPERAND-1 COMPERAND-2) 160 ;; "Order of types: pair NIL vec string symbol num fbpi other" 161 (COND 162 ((EQ COMPERAND-1 COMPERAND-2) NIL) 163 ((consp COMPERAND-1) 164 (COND 165 ( (consp COMPERAND-2) 166 (COND 167 ( (EQUAL (qcar COMPERAND-1) (qcar COMPERAND-2)) 168 (LEXGREATERP (qcdr COMPERAND-1) (qcdr COMPERAND-2)) ) 169 ( (LEXGREATERP (qcar COMPERAND-1) (qcar COMPERAND-2)) ) ) ) 170 ('else t))) 171 ((consp COMPERAND-2) NIL) 172 ((NULL COMPERAND-1) 'T ) 173 ((NULL COMPERAND-2) NIL) 174 ((VECP COMPERAND-1) 175 (COND 176 ((VECP COMPERAND-2) (LEXVGREATERP COMPERAND-1 COMPERAND-2) ) 177 ('else t))) 178 ((VECP COMPERAND-2) NIL) 179 ((stringp COMPERAND-1) 180 (COND 181 ((stringp COMPERAND-2) 182 (STRING-GREATERP COMPERAND-1 COMPERAND-2) ) 183 ('else t))) 184 ((stringp COMPERAND-2) NIL) 185 ((symbolp COMPERAND-1) 186 (COND 187 ((symbolp COMPERAND-2) 188 (STRING-GREATERP (symbol-name COMPERAND-1) (symbol-name COMPERAND-2)) ) 189 ('else t))) 190 ((symbolp COMPERAND-2) NIL ) 191 ((numberp COMPERAND-1) 192 (COND 193 ( (numberp COMPERAND-2) 194 (> COMPERAND-1 COMPERAND-2) ) 195 ('else t))) 196 ((numberp COMPERAND-2) NIL) 197 ((CHARACTERP COMPERAND-1) 198 (COND 199 ((CHARACTERP COMPERAND-2) 200 (CHAR-GREATERP COMPERAND-1 COMPERAND-2) ) 201 ('else t))) 202 ((CHARACTERP COMPERAND-2) NIL ) 203 ((FBPIP COMPERAND-1) 204 (COND 205 ((FBPIP COMPERAND-2) 206 (LEXGREATERP (BPINAME COMPERAND-1) (BPINAME COMPERAND-2)) ) 207 ('else t))) 208 ((FBPIP COMPERAND-2) NIL) 209 ((> (SXHASH COMPERAND-1) (SXHASH COMPERAND-2))))) 210 211(DEFUN LEXVGREATERP (VECTOR-COMPERAND-1 VECTOR-COMPERAND-2) 212 (declare (simple-vector vector-comperand-1 vector-comperand-2)) 213 (PROG ((L1 (length VECTOR-COMPERAND-1)) 214 (L2 (length VECTOR-COMPERAND-2)) 215 (I -1) 216 T1 T2) 217 (declare (fixnum i l1 l2) ) 218 LP (setq i (1+ i)) 219 (COND 220 ((EQL L1 I) (RETURN NIL)) 221 ((EQL L2 I) (RETURN 'T))) 222 (COND 223 ((EQUAL 224 (SETQ T1 (svref VECTOR-COMPERAND-1 I)) 225 (SETQ T2 (svref VECTOR-COMPERAND-2 I))) 226 (GO LP))) 227 (RETURN (LEXGREATERP T1 T2)) ) ) 228 229 230(DEFUN GGREATERP (COMPERAND-1 COMPERAND-2) 231 ;; "Order of types: symbol pair NIL vec string num fbpi other" 232 (COND 233 ((EQ COMPERAND-1 COMPERAND-2) NIL) 234 ((symbolp COMPERAND-1) 235 (COND 236 ((symbolp COMPERAND-2) 237 (CGREATERP (symbol-name COMPERAND-1) (symbol-name COMPERAND-2)) ) 238 ('else t))) 239 ((symbolp COMPERAND-2) NIL ) 240 ((consp COMPERAND-1) 241 (COND 242 ( (consp COMPERAND-2) 243 (COND 244 ( (EQUAL (qcar COMPERAND-1) (qcar COMPERAND-2)) 245 (GGREATERP (qcdr COMPERAND-1) (qcdr COMPERAND-2)) ) 246 ( (GGREATERP (qcar COMPERAND-1) (qcar COMPERAND-2)) ) ) ) 247 ('else t))) 248 ((consp COMPERAND-2) NIL) 249 ((NULL COMPERAND-1) 'T ) 250 ((NULL COMPERAND-2) NIL) 251 ((VECP COMPERAND-1) 252 (COND 253 ((VECP COMPERAND-2) (VGREATERP COMPERAND-1 COMPERAND-2) ) 254 ('else t))) 255 ((VECP COMPERAND-2) NIL) 256 ((stringp COMPERAND-1) 257 (COND 258 ((stringp COMPERAND-2) 259 (CGREATERP COMPERAND-1 COMPERAND-2) ) 260 ('else t))) 261 ((stringp COMPERAND-2) NIL) 262 ((numberp COMPERAND-1) 263 (COND 264 ( (numberp COMPERAND-2) 265 (> COMPERAND-1 COMPERAND-2) ) 266 ('else t))) 267 ((numberp COMPERAND-2) NIL) 268 ((CHARACTERP COMPERAND-1) 269 (COND 270 ((CHARACTERP COMPERAND-2) 271 (CHAR> COMPERAND-1 COMPERAND-2) ) 272 ('else t))) 273 ((CHARACTERP COMPERAND-2) NIL ) 274 ((FBPIP COMPERAND-1) 275 (COND 276 ((FBPIP COMPERAND-2) 277 (GGREATERP (BPINAME COMPERAND-1) (BPINAME COMPERAND-2)) ) 278 ('else t))) 279 ((FBPIP COMPERAND-2) NIL) 280 ((> (SXHASH COMPERAND-1) (SXHASH COMPERAND-2))))) 281 282(DEFUN VGREATERP (VECTOR-COMPERAND-1 VECTOR-COMPERAND-2) 283 (declare (simple-vector vector-comperand-1 vector-comperand-2)) 284 (PROG ((L1 (length VECTOR-COMPERAND-1)) 285 (L2 (length VECTOR-COMPERAND-2)) 286 (I -1) 287 T1 T2) 288 (declare (fixnum i l1 l2) ) 289 LP (setq i (1+ i)) 290 (COND 291 ((EQL L1 I) (RETURN NIL)) 292 ((EQL L2 I) (RETURN 'T))) 293 (COND 294 ((EQUAL 295 (SETQ T1 (svref VECTOR-COMPERAND-1 I)) 296 (SETQ T2 (svref VECTOR-COMPERAND-2 I))) 297 (GO LP))) 298 (RETURN (GGREATERP T1 T2)) ) ) 299 300(defvar SORTGREATERP #'GGREATERP "default sorting predicate") 301 302(defun GLESSEQP (X Y) (NOT (GGREATERP X Y))) 303 304(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y))) 305 306 307; 10.3 Creating Symbols 308 309(DEFUN IS_GENVAR (X) 310 (AND (IDENTP X) 311 (let ((y (symbol-name x))) 312 (and (char= #\$ (elt y 0)) (> (size y) 1) (digitp (elt y 1)))))) 313 314; 14 SEQUENCES 315 316; 14.2 Concatenating, Mapping, and Reducing Sequences 317 318(defun |delete| (item sequence) 319 (cond ((symbolp item) (remove item sequence :test #'eq)) 320 ((and (atom item) (not (arrayp item))) (remove item sequence)) 321 (T (remove item sequence :test #'equalp)))) 322 323; 15 LISTS 324 325; 15.2 Lists 326 327(DEFUN LASTATOM (L) (if (ATOM L) L (LASTATOM (CDR L)))) 328 329(defun DROP (N X &aux m) 330 "Return a pointer to the Nth cons of X, counting 0 as the first cons." 331 (COND ((EQL N 0) X) 332 ((> N 0) (DROP (1- N) (CDR X))) 333 ((>= (setq m (+ (length x) N)) 0) (take m x)) 334 ((CROAK (list "Bad args to DROP" N X))))) 335 336(DEFUN TAKE (N X &aux m) 337 "Returns a list of the first N elements of list X." 338 (COND ((EQL N 0) NIL) 339 ((> N 0) (CONS (CAR X) (TAKE (1- N) (CDR X)))) 340 ((>= (setq m (+ (length x) N)) 0) (DROP m x)) 341 ((CROAK (list "Bad args to DROP" N X))))) 342 343; 15.4 Substitution of Expressions 344 345;; needed for substNames (always copy) 346(DEFUN SUBSTQ (NEW OLD FORM) 347 "Version of SUBST that uses EQ rather than EQUAL on the world." 348 (PROG (NFORM HNFORM ITEM) 349 (SETQ HNFORM (SETQ NFORM (CONS () ()))) 350 LP (RPLACD NFORM 351 (COND ((EQ FORM OLD) (SETQ FORM ()) NEW ) 352 ((NOT (PAIRP FORM)) FORM ) 353 ((EQ (SETQ ITEM (CAR FORM)) OLD) (CONS NEW ()) ) 354 ((PAIRP ITEM) (CONS (SUBSTQ NEW OLD ITEM) ()) ) 355 ((CONS ITEM ())))) 356 (if (NOT (PAIRP FORM)) (RETURN (CDR HNFORM))) 357 (SETQ NFORM (CDR NFORM)) 358 (SETQ FORM (CDR FORM)) 359 (GO LP))) 360 361(defun SUBLISLIS (newl oldl form) 362 (sublis (mapcar #'cons oldl newl) form)) 363 364; 15.5 Using Lists as Sets 365 366(DEFUN |set_sum| (X Y) 367 (COND ((ATOM Y) X) 368 ((ATOM X) Y) 369 ((MEMBER (CAR X) Y :test #'equal) (|set_sum| (CDR X) Y)) 370 ((|set_sum| (CDR X) (CONS (CAR X) Y))))) 371 372(defun |set_difference| (l1 l2) (set-difference l1 l2 :test #'equal)) 373 374 375(DEFUN PREDECESSOR (TL L) 376 "Returns the sublist of L whose CDR is EQ to TL." 377 (COND ((ATOM L) NIL) 378 ((EQ TL (CDR L)) L) 379 ((PREDECESSOR TL (CDR L))))) 380 381(defun remdup (l) (remove-duplicates l :test #'equalp)) 382 383; 15.6 Association Lists 384 385(defun DELASC (u v) "Returns a copy of a-list V in which any pair with key U is deleted." 386 (cond ((atom v) nil) 387 ((or (atom (car v))(not (equal u (caar v)))) 388 (cons (car v) (DELASC u (cdr v)))) 389 ((cdr v)))) 390 391(DEFUN ADDASSOC (X Y L) 392 "Put the association list pair (X . Y) into L, erasing any previous association for X" 393 (COND ((ATOM L) (CONS (CONS X Y) L)) 394 ((EQUAL X (CAAR L)) (CONS (CONS X Y) (CDR L))) 395 ((CONS (CAR L) (ADDASSOC X Y (CDR L)))))) 396 397(DEFUN DELLASOS (U V) 398 "Remove any association pair (U . X) from list V." 399 (COND ((ATOM V) NIL) 400 ((EQUAL U (CAAR V)) (CDR V)) 401 ((CONS (CAR V) (DELLASOS U (CDR V)))))) 402 403(DEFUN ASSOCLEFT (X) 404 "Returns all the keys of association list X." 405 (if (ATOM X) X (mapcar #'car x))) 406 407(DEFUN ASSOCRIGHT (X) 408 "Returns all the datums of association list X." 409 (if (ATOM X) X (mapcar #'cdr x))) 410 411(DEFUN LASSOC (X Y) 412 "Return the datum associated with key X in association list Y." 413 (PROG () 414 A (COND ((ATOM Y) (RETURN NIL)) 415 ((EQUAL (CAAR Y) X) (RETURN (CDAR Y))) ) 416 (SETQ Y (CDR Y)) 417 (GO A))) 418 419(DEFUN |rassoc| (X Y) 420 "Return the datum associated with key X in association list Y." 421 (PROG () 422 A (COND ((ATOM Y) (RETURN NIL)) 423 ((EQUAL (CDAR Y) X) (RETURN (CAAR Y))) ) 424 (SETQ Y (CDR Y)) 425 (GO A))) 426 427; (defun QLASSQ (p a-list) (let ((y (assoc p a-list :test #'eq))) (if y (cdr y)))) 428(defun QLASSQ (p a-list) (cdr (assq p a-list))) 429 430(defun MAKE_PAIRS (x y) (mapcar #'cons x y)) 431 432;;; Operations on Association Sets (AS) 433 434(defun AS_INSERT (A B L) 435 (let ((pp (assoc A L :test #'equal))) 436 (if pp 437 (progn 438 (setf (cdr pp) B) 439 L)) 440 (cons (cons A B) L))) 441 442; 22 INPUT/OUTPUT 443 444; 22.2 Input Functions 445 446; 22.2.1 Input from Character Streams 447 448(defvar *EOF* NIL) 449 450 451; 22.3 Output Functions 452 453; 22.3.1 Output to Character Streams 454 455(defvar |$sayBrightlyStream| nil "if not nil, gives stream for sayBrightly output") 456 457(defun |get_lisp_std_out| () *standard-output*) 458 459(defun |get_lisp_error_out| () *error-output*) 460 461(defvar |$fortranOutputStream|) 462 463(defvar |$highlightAllowed| nil "Used in BRIGHTPRINT and is a )set variable.") 464 465(defvar |$highlightFontOn| (concat " " |$boldString|) 466 "switch to highlight font") 467(defvar |$highlightFontOff| (concat |$normalString| " ") 468 "return to normal font") 469 470(defun SAY (&rest x) (progn (MESSAGEPRINT X) (TERPRI))) 471 472(DEFUN MESSAGEPRINT (X) (mapc #'messageprint-1 X)) 473 474(DEFUN MESSAGEPRINT-1 (X) 475 (COND ((OR (EQ X '|%l|) (EQUAL X "%l")) (TERPRI)) 476 ((STRINGP X) (PRINC X)) 477 ((IDENTP X) (PRINC X)) 478 ((ATOM X) (PRINC X)) 479 ((PRINC "(") (MESSAGEPRINT-1 (CAR X)) 480 (MESSAGEPRINT-2 (CDR X)) (PRINC ")")))) 481 482(DEFUN MESSAGEPRINT-2 (X) 483 (if (ATOM X) 484 (if (NULL X) NIL (progn (PRINC " . ") (MESSAGEPRINT-1 X))) 485 (progn (PRINC " ") (MESSAGEPRINT-1 (CAR X)) (MESSAGEPRINT-2 (CDR X))))) 486 487(DEFUN BLANKS (N &optional (stream *standard-output*)) "Print N blanks." 488 (do ((i 1 (the fixnum(1+ i)))) 489 ((> i N))(declare (fixnum i n)) (princ " " stream))) 490 491; 24 ERRORS 492 493; 24.2 Specialized Error-Signalling Forms and Macros 494 495(defun MOAN (&rest x) (|sayBrightly| `(|%l| "===> " ,@X |%l|))) 496 497(DEFUN FAIL () (|systemError| '"Antique error (FAIL ENTERED)")) 498 499(defun CROAK (&rest x) (|systemError| x)) 500 501; 25 MISCELLANEOUS FEATURES 502 503(defun MAKE_REASONABLE (Z) 504 (if (> (length Z) 30) (CONCAT "expression beginning " (subseq Z 0 20)) Z)) 505 506(defun DROPTRAILINGBLANKS (LINE) 507 (let ((l (length LINE))) 508 (if (and (> l 0) 509 (char= (char LINE (1- l)) #\ )) 510 (string-right-trim " " LINE) 511 LINE))) 512 513(defun print-and-eval-defun (name body) 514 (eval body) 515 (|print_defun| name body) 516 ) 517 518(defun eval-defun (name body) (eval (macroexpandall body))) 519 520; This function was modified by Greg Vanuxem on March 31, 2005 521; to handle the special case of #'(lambda ..... which expands 522; into (function (lambda ..... 523; 524; The extra if clause fixes bugs #196 and #114 525; 526; an example that used to cause the failure was: 527; )set func comp off 528; f(xl:LIST FRAC INT): LIST FRAC INT == map(x +-> x, xl) 529; f [1,2,3] 530; 531; which expanded into 532; 533; (defun |xl;f;1;initial| (|#1| |envArg|) 534; (prog (#:G1420) 535; (return 536; (progn 537; (lett #:G1420 'uninitialized_variable |f| |#1;f;1:initial|) 538; (spadcall 539; (cons (|function| (lambda (#:G1420 |envArg|) #:G1420)) (vector)) 540; |#1| 541; (qrefelt |*1;f;1;initial;MV| 0)))))) 542; 543; the (|function| (lambda form used to cause an infinite expansion loop 544; 545(defun macroexpandall (sexpr) 546 (cond 547 ((atom sexpr) sexpr) 548 ((eq (car sexpr) 'quote) sexpr) 549 ((eq (car sexpr) 'defun) 550 (cons (car sexpr) (cons (cadr sexpr) 551 (mapcar #'macroexpandall (cddr sexpr))))) 552 ((and (symbolp (car sexpr)) (macro-function (car sexpr))) 553 (do () 554 ((not (and (consp sexpr) (symbolp (car sexpr)) 555 (macro-function (car sexpr))))) 556 (setq sexpr (macroexpand sexpr))) 557 (if (consp sexpr) 558 (let ((a (car sexpr)) (b (cadr sexpr))) 559 (if (and (eq a 'function) (consp b) (eq (car b) 'lambda)) 560 (cons a (list (cons (car b) 561 (mapcar #'macroexpandall (cdadr sexpr))))) 562 (mapcar #'macroexpandall sexpr))) 563 sexpr)) 564 ('else 565 (mapcar #'macroexpandall sexpr)))) 566 567 568(defun compile-defun (name body) (eval body) (compile name)) 569 570(DEFUN |leftBindingPowerOf| (X IND &AUX (Y (GET X IND))) 571 (IF Y (ELEMN Y 3 0) 0)) 572 573(DEFUN |rightBindingPowerOf| (X IND &AUX (Y (GET X IND))) 574 (IF Y (ELEMN Y 4 105) 105)) 575 576(defun |print_full2| (expr stream) 577 (let ((*print-circle* t) (*print-array* t) *print-level* *print-length*) 578 (print expr stream) 579 (terpri stream))) 580 581(defun |print_full1| (expr) (|print_full2| expr *standard-output*)) 582 583;; moved here from preparse.lisp 584 585(defvar tab-size-in-spaces 8 586 "How many spaces do we consider a #\Tab character?") 587 588(defun NEXT-TAB-LOC (i) 589 "Given a character position I, on what position would a #\Tab land 590us?" 591 (* tab-size-in-spaces (1+ (truncate i tab-size-in-spaces)))) 592 593(defun EXPAND_TABS (str) 594 "Given a string STR, expand all #\Tab characters to spaces, minding 595the correct column each #\Tab would carry us to. 596 597This function respects intermediate #\Newline characters and drops 598#\Return characters." 599 (cond 600 ((stringp str) 601 (with-output-to-string (s) 602 (loop :with column := 0 603 :for c :across str 604 :do (case c 605 (#\Tab 606 ;; How many spaces does our tab carry us forward 607 ;; by? 608 (let ((num-spaces (- (next-tab-loc column) column))) 609 (incf column num-spaces) 610 ;; This format string just writes something N 611 ;; times without consing up garbage. 612 (format s "~v@{~C~:*~}" num-spaces #\Space))) 613 (#\Newline 614 (setf column 0) 615 (write-char #\Newline s)) 616 (#\Return 617 ;; Drop this character completely. 618 nil) 619 (t 620 (incf column) 621 (write-char c s)))))) 622 (t 623 str))) 624 625;; stream handling for paste-in generation 626 627(defun |applyWithOutputToString| (func args) 628 ;; returns the cons of applying func to args and a string produced 629 ;; from standard-output while executing. 630 (let* ((*standard-output* (make-string-output-stream)) 631 (curoutstream *standard-output*) 632 (*error-output* *standard-output*) 633 (|$algebraOutputStream| (CONS NIL *standard-output*)) 634 val) 635 (declare (special curoutstream 636 |$algebraOutputStream|)) 637 (setq val (catch 'spad_reader 638 (apply (symbol-function func) args))) 639 (cons val (get-output-stream-string *standard-output*)))) 640 641(defun |breakIntoLines| (str) 642 (let ((bol 0) (eol) (line-list nil)) 643 (loop 644 (setq eol (position #\Newline str :start bol)) 645 (if (null eol) (return)) 646 (if (> eol bol) 647 (setq line-list (cons (subseq str bol eol) line-list))) 648 (setq bol (+ eol 1))) 649 (nreverse line-list))) 650 651; moved from comp.lisp 652 653;;; Common Block section 654 655(defun |compAndDefine| (L) 656 (let ((|$comp370_apply| (function print-and-eval-defun))) 657 (declare (special |$comp370_apply|)) 658 (COMP L))) 659 660(defun comp_quietly_using_driver (driver fn) 661 (let ((|$comp370_apply| 662 (if |$InteractiveMode| 663 (if |$compileDontDefineFunctions| #'compile-defun #'eval-defun) 664 #'|print_defun|)) 665 ;; following creates a null outputstream if $InteractiveMode 666 (*standard-output* 667 (if |$InteractiveMode| (make-broadcast-stream) 668 *standard-output*)) 669 (*compile-verbose* nil)) 670 (declare (special |$comp370_apply|)) 671 #-:GCL 672 (handler-bind ((warning #'muffle-warning) 673 #+:sbcl (sb-ext::compiler-note #'muffle-warning)) 674 (funcall driver fn) 675 ) 676 #+:GCL 677 (funcall driver fn) 678)) 679 680(defun |compQuietly| (fn) 681 (comp_quietly_using_driver #'COMP fn)) 682 683(defun |compileFileQuietly| (fn) 684 (comp_quietly_using_driver #'COMPILE-FILE fn)) 685 686(defun |compileQuietly| (fn) 687 (comp_quietly_using_driver #'COMP370 fn)) 688 689;; used to be called POSN - but that interfered with a CCL function 690(DEFUN POSN1 (X L) (position x l :test #'equal)) 691 692; end of moved fragment 693 694;;; moved from debug.lisp 695 696; NAME: Debugging Package 697; PURPOSE: Debugging hooks for Boot code 698 699(defun ENABLE_BACKTRACE (&rest arg)) 700 701(defun |adjoin_equal|(x y) (ADJOIN x y :test #'equal)) 702 703(defun |remove_equal|(x y) (REMOVE x y :test #'equal)) 704 705(defun WHOCALLED(n) nil) ;; no way to look n frames up the stack 706 707(defun heapelapsed () 0) 708 709(defun |goGetTracerHelper| (dn f oname alias options modemap) 710 (lambda(&rest l) 711 (|goGetTracer| l dn f oname alias options modemap))) 712 713(defun |setSf| (sym fn) (SETF (SYMBOL-FUNCTION sym) fn)) 714 715(DEFUN IS_SHARP_VAR (X) 716 (AND (IDENTP X) 717 (EQL (ELT (PNAME X) 0) #\#) 718 (INTEGERP (parse-integer (symbol-name X) :start 1)))) 719 720(defun |char_to_digit|(x) (digit-char-p x)) 721 722(defun SPADSYSNAMEP (STR) 723 (let (n i j) 724 (AND (SETQ N (MAXINDEX STR)) 725 (SETQ I (position #\. STR :start 1)) 726 (SETQ J (position #\, STR :start (1+ I))) 727 (do ((k (1+ j) (1+ k))) 728 ((> k n) t) 729 (if (not (digitp (elt str k))) (return nil)))))) 730 731; ********************************************************************** 732; Utility functions for Tracing Package 733; ********************************************************************** 734 735(MAKEPROP '|coerce| '/TRANSFORM '(& & *)) 736(MAKEPROP '|comp| '/TRANSFORM '(& * * &)) 737(MAKEPROP '|compIf| '/TRANSFORM '(& * * &)) 738 739; by having no transform for the 3rd argument, it is simply not printed 740 741(MAKEPROP '|compFormWithModemap| '/TRANSFORM '(& * * & *)) 742 743;;; A "resumable" break loop for use in trace etc. Unfortunately this 744;;; only worked for CCL. We need to define a Common Lisp version. For 745;;; now the function is defined but does nothing. 746(defun interrupt (&rest ignore)) 747 748;;; end of moved fragment 749