1(in-package "BOOT") 2 3;;; Making constant doubles 4(defun |make_DF|(x e) 5 (let ((res (read-from-string (format nil "~D.0d~D" x e)))) 6 res) 7) 8 9(defmacro |mk_DF|(x e) (|make_DF| x e)) 10 11;;; Fast array accessors 12 13(defmacro QAREF1(v i) 14`(aref (the (simple-array T (*)) ,v) ,i)) 15 16(defmacro QSETAREF1(v i s) 17 `(setf (aref (the (simple-array T (*)) ,v) ,i) ,s)) 18 19;;; arrays of arbitrary offset 20 21(defmacro QAREF1O(v i o) 22 `(aref (the (simple-array T (*)) ,v) (|sub_SI| ,i ,o))) 23 24(defmacro QSETAREF1O (v i s o) 25 `(setf (aref (the (simple-array T (*)) ,v) 26 (|sub_SI| ,i ,o)) 27 ,s)) 28 29(defmacro QAREF2O(m i j oi oj) 30 `(aref (the (simple-array T (* *)) ,m) 31 (|sub_SI| ,i ,oi) 32 (|sub_SI| ,j ,oj))) 33 34(defmacro QSETAREF2O (m i j r oi oj) 35 `(setf (aref (the (simple-array T (* *)) ,m) 36 (|sub_SI| ,i ,oi) 37 (|sub_SI| ,j ,oj)) 38 ,r)) 39 40;;; array creation 41 42(defun MAKEARR1 (size init) 43 (make-array size :initial-element init)) 44 45 46(defun MAKE_MATRIX (size1 size2) 47 (make-array (list size1 size2))) 48 49(defun MAKE_MATRIX1 (size1 size2 init) 50 (make-array (list size1 size2) :initial-element init)) 51 52;;; array dimensions 53 54(defmacro ANROWS (v) 55 `(array-dimension (the (simple-array T (* *)) ,v) 0)) 56 57(defmacro ANCOLS (v) 58 `(array-dimension (the (simple-array T (* *)) ,v) 1)) 59 60;;; general arrays 61(defun GENERAL_ARRAY? (v) (typep v '(array t))) 62 63(defun MAKE_TYPED_ARRAY (dims lt) (make-array dims :element-type lt)) 64 65;;; string accessors 66 67(defmacro STR_ELT(s i) 68 `(char-code (char (the string ,s) (the fixnum ,i)))) 69 70(defmacro STR_SETELT(s i c) 71 (if (integerp c) 72 `(progn 73 (setf (char (the string ,s) (the fixnum ,i)) 74 (code-char (the fixnum ,c))) 75 ,c) 76 (let ((sc (gensym))) 77 `(let ((,sc ,c)) 78 (setf (char (the string ,s) (the fixnum ,i)) 79 (code-char (the fixnum ,sc))) 80 ,sc)))) 81 82(defmacro STR_ELT1(s i) 83 `(char-code (char (the string ,s) (the fixnum (- (the fixnum ,i) 1))))) 84 85(defmacro STR_SETELT1(s i c) 86 (if (integerp c) 87 `(progn 88 (setf (char (the string ,s) (the fixnum (- (the fixnum ,i) 1))) 89 (code-char (the fixnum ,c))) 90 ,c) 91 (let ((sc (gensym))) 92 `(let ((,sc ,c)) 93 (setf (char (the string ,s) (the fixnum (- (the fixnum ,i) 1))) 94 (code-char (the fixnum ,sc))) 95 ,sc)))) 96 97;;; Creating characters 98 99(defun |STR_to_CHAR_fun| (s) 100 (if (eql (length s) 1) 101 (STR_ELT s 0) 102 (|error| "String is not a single character"))) 103 104(defmacro |STR_to_CHAR| (s) 105 (if (and (stringp s) (eql (length s) 1)) 106 (STR_ELT s 0) 107 `(|STR_to_CHAR_fun| ,s))) 108 109;;; Vectors and matrices of of small integer 32-bit numbers 110 111(defmacro suffixed_name(name s) 112 `(intern (concatenate 'string (symbol-name ',name) 113 (format nil "~A" ,s)))) 114 115#+:sbcl 116(defmacro sbcl_make_sized_vector(nb n) 117 (let ((get-tag (find-symbol "%VECTOR-WIDETAG-AND-N-BITS" "SB-IMPL")) 118 (length-sym nil)) 119 (if (null get-tag) 120 (progn 121 (setf get-tag 122 (find-symbol "%VECTOR-WIDETAG-AND-N-BITS-SHIFT" 123 "SB-IMPL")) 124 (setf length-sym (find-symbol "VECTOR-LENGTH-IN-WORDS" 125 "SB-IMPL")))) 126 (multiple-value-bind (typetag n-bits) 127 (FUNCALL get-tag `(unsigned-byte ,nb)) 128 (let ((length-form 129 (if length-sym 130 `(,length-sym ,n ,n-bits) 131 `(ceiling (* ,n ,n-bits) sb-vm:n-word-bits)))) 132 `(SB-KERNEL:ALLOCATE-VECTOR ,typetag ,n ,length-form))))) 133 134(defmacro DEF_SIZED_UOPS(nb) 135 136`(progn 137(defmacro ,(suffixed_name ELT_U nb) (v i) 138 `(aref (the (simple-array (unsigned-byte ,',nb) (*)) ,v) ,i)) 139 140(defmacro ,(suffixed_name SETELT_U nb)(v i s) 141 `(setf (aref (the (simple-array (unsigned-byte ,',nb) (*)) ,v) ,i) 142 ,s)) 143 144#+:sbcl 145(let ((get-tag (find-symbol "%VECTOR-WIDETAG-AND-N-BITS" "SB-IMPL")) 146 (length-sym nil) (get-tag2 nil)) 147 (if (null get-tag) 148 (progn 149 (setf get-tag2 150 (find-symbol "%VECTOR-WIDETAG-AND-N-BITS-SHIFT" 151 "SB-IMPL")) 152 (setf length-sym (find-symbol "VECTOR-LENGTH-IN-WORDS" 153 "SB-IMPL")))) 154 (cond 155 ((and (null get-tag) (or (null get-tag2) (null length-sym))) 156 (defun ,(suffixed_name GETREFV_U nb)(n x) 157 (make-array n :initial-element x 158 :element-type '(unsigned-byte ,nb)))) 159 (t 160 (defun ,(suffixed_name GETREFV_U nb)(n x) 161 (let ((vec (sbcl_make_sized_vector ,nb n))) 162 (fill vec x) 163 vec))))) 164 165#-:sbcl 166(defun ,(suffixed_name GETREFV_U nb)(n x) 167 (make-array n :initial-element x 168 :element-type '(unsigned-byte ,nb))) 169 170(defmacro ,(suffixed_name QV_LEN_U nb)(v) 171 `(length (the (simple-array (unsigned-byte ,',nb) (*)) ,v))) 172 173(defmacro ,(suffixed_name MAKE_MATRIX_U nb) (n m) 174 `(make-array (list ,n ,m) :element-type '(unsigned-byte ,',nb))) 175 176(defmacro ,(suffixed_name MAKE_MATRIX1_U nb) (n m s) 177 `(make-array (list ,n ,m) :element-type '(unsigned-byte ,',nb) 178 :initial-element ,s)) 179 180(defmacro ,(suffixed_name AREF2_U nb) (v i j) 181 `(aref (the (simple-array (unsigned-byte ,',nb) (* *)) ,v) ,i ,j)) 182 183(defmacro ,(suffixed_name SETAREF2_U nb) (v i j s) 184 `(setf (aref (the (simple-array (unsigned-byte ,',nb) (* *)) ,v) ,i ,j) 185 ,s)) 186 187(defmacro ,(suffixed_name ANROWS_U nb) (v) 188 `(array-dimension (the (simple-array (unsigned-byte ,',nb) (* *)) ,v) 0)) 189 190(defmacro ,(suffixed_name ANCOLS_U nb) (v) 191 `(array-dimension (the (simple-array (unsigned-byte ,',nb) (* *)) ,v) 1)) 192 193)) 194 195(DEF_SIZED_UOPS 32) 196(DEF_SIZED_UOPS 16) 197(DEF_SIZED_UOPS 8) 198 199;;; Modular arithmetic 200 201(deftype machine_int () '(unsigned-byte 64)) 202 203;;; (x*y + z) using 32-bit x and y and 64-bit z and assuming that 204;;; intermediate results fits into 64 bits 205(defmacro QSMULADD64_32 (x y z) 206 `(the machine_int 207 (+ (the machine_int 208 (* (the (unsigned-byte 32) ,x) 209 (the (unsigned-byte 32) ,y))) 210 (the machine_int ,z)))) 211 212(defmacro QSMUL64_32 (x y) 213 `(the machine_int 214 (* (the (unsigned-byte 32) ,x) 215 (the (unsigned-byte 32) ,y)))) 216 217 218(defmacro QSMOD64_32 (x p) 219 `(the (unsigned-byte 32) 220 (rem (the machine_int ,x) (the (unsigned-byte 32) ,p)))) 221 222(defmacro QSMULADDMOD64_32 (x y z p) 223 `(QSMOD64_32 (QSMULADD64_32 ,x ,y ,z) ,p)) 224 225(defmacro QSDOT2_64_32 (a1 b1 a2 b2) 226 `(QSMULADD64_32 ,a1 ,b1 (QSMUL64_32 ,a2 ,b2))) 227 228(defmacro QSDOT2MOD64_32 (a1 b1 a2 b2 p) 229 `(QSMOD64_32 (QSDOT2_64_32 ,a1 ,b1 ,a2 ,b2) , p)) 230 231(defmacro QSMULMOD32 (x y p) 232 `(QSMOD64_32 (QSMUL64_32 ,x ,y) ,p)) 233 234;;; Modular scalar product 235 236(defmacro QMODDOT0 (eltfun varg1 varg2 ind1 ind2 kk s0 p) 237 `(let ((s ,s0) 238 (v1 ,varg1) 239 (v2 ,varg2) 240 (i1 ,ind1) 241 (i2 ,ind2) 242 (k0 ,kk) 243 (k 0)) 244 (declare (type machine_int s) 245 (type fixnum i1 i2 k k0)) 246 (prog () 247 l1 248 (if (>= k k0) (return (QSMOD64_32 s ,p))) 249 (setf s (QSMULADD64_32 (,eltfun v1 (|add_SI| i1 k)) 250 (,eltfun v2 (|add_SI| i2 k)) 251 s)) 252 (setf k (|inc_SI| k)) 253 (go l1)))) 254 255(defmacro QMODDOT32 (v1 v2 ind1 ind2 kk s0 p) 256 `(QMODDOT0 ELT32 ,v1 ,v2 ,ind1 ,ind2 ,kk ,s0 ,p)) 257 258;;; Support for HashState domain. 259;;; Here the FNV-1a algorithm is employed. 260;;; More about the FNV-1a algorithm can be found at Wikipedia, see 261;;; http://en.wikipedia.org/wiki/Fowler-Noll-Vo_hash_function. 262 263;;; FNV-1a hash 264(defconstant HASHSTATEBASIS 14695981039346656037) 265(defconstant HASHSTATEPRIME 1099511628211) 266; FNV-1a algorithm with 64bit truncation (18446744073709551615=2^64-1). 267(defmacro HASHSTATEUPDATE (x y) 268 `(logand (* HASHSTATEPRIME (logxor ,x ,y)) 18446744073709551615)) 269; Make a fixnum out of (unsigned-byte 64) 270(defmacro HASHSTATEMAKEFIXNUM (x) 271 `(logand ,x most-positive-fixnum)) 272(defmacro HASHSTATEMOD (x y) 273 `(mod ,x ,y)) 274 275;;; Floating point macros 276 277;; Before version 1.8 Closure CL had buggy floating point optimizer, so 278;; for it we need to omit type declarations to disable optimization 279#-(and :openmcl (not :CCL-1.8)) 280(defmacro DEF_DF_BINOP (name op) 281 `(defmacro ,name (x y) `(the double-float (,',op (the double-float ,x) 282 (the double-float ,y))))) 283#+(and :openmcl (not :CCL-1.8)) 284(defmacro DEF_DF_BINOP (name op) `(defmacro ,name (x y) `(,',op ,x ,y))) 285 286(DEF_DF_BINOP |add_DF| +) 287(DEF_DF_BINOP |mul_DF| *) 288(DEF_DF_BINOP |max_DF| MAX) 289(DEF_DF_BINOP |min_DF| MIN) 290(DEF_DF_BINOP |sub_DF| -) 291(DEF_DF_BINOP |div_DF| /) 292 293(defmacro |abs_DF| (x) `(FLOAT-SIGN (the (double-float 1.0d0 1.0d0) 1.0d0) 294 (the double-float ,x))) 295 296#-(and :openmcl (not :CCL-1.8)) 297(progn 298(defmacro |less_DF| (x y) `(< (the double-float ,x) 299 (the double-float ,y))) 300(defmacro |eql_DF| (x y) `(= (the double-float ,x) 301 (the double-float ,y))) 302(defmacro |expt_DF_I| (x y) `(EXPT (the double-float ,x) 303 (the integer ,y))) 304(defmacro |expt_DF| (x y) `(EXPT (the double-float ,x) 305 (the double-float ,y))) 306(defmacro |mul_DF_I| (x y) `(* (the double-float ,x) 307 (the integer ,y))) 308(defmacro |div_DF_I| (x y) `(/ (the double-float ,x) 309 (the integer ,y))) 310(defmacro |zero?_DF| (x) `(ZEROP (the double-float ,x))) 311(defmacro |negative?_DF| (x) `(MINUSP (the double-float ,x))) 312(defmacro |sqrt_DF| (x) `(SQRT (the double-float ,x))) 313(defmacro |log_DF| (x) `(LOG (the double-float ,x))) 314(defmacro |qsqrt_DF| (x) `(the double-float (SQRT 315 (the (double-float 0.0d0 *) ,x)))) 316(defmacro |qlog_DF| (x) `(the double-float (LOG 317 (the (double-float 0.0d0 *) ,x)))) 318 319(defmacro DEF_DF_UNOP (name op) 320 `(defmacro ,name (x) `(the double-float (,',op (the double-float ,x))))) 321) 322 323#+(and :openmcl (not :CCL-1.8)) 324(progn 325(defmacro |less_DF| (x y) `(< ,x ,y)) 326(defmacro |eql_DF| (x y) `(EQL ,x ,y)) 327(defmacro |expt_DF_I| (x y) `(EXPT ,x ,y)) 328(defmacro |expt_DF| (x y) `(EXPT ,x ,y)) 329(defmacro |mul_DF_I| (x y) `(* ,x ,y)) 330(defmacro |div_DF_I| (x y) `(/ ,x ,y)) 331(defmacro |zero?_DF| (x) `(ZEROP ,x)) 332(defmacro |negative?_DF| (x) `(MINUSP ,x)) 333(defmacro |sqrt_DF|(x) `(SQRT ,x)) 334(defmacro |log_DF| (x) `(LOG ,x)) 335(defmacro |qsqrt_DF|(x) `(SQRT ,x)) 336(defmacro |qlog_DF| (x) `(LOG ,x)) 337 338 339(defmacro DEF_DF_UNOP (name op) 340 `(defmacro ,name (x) `(,',op ,x))) 341) 342 343 344(DEF_DF_UNOP |exp_DF| EXP) 345(DEF_DF_UNOP |minus_DF| -) 346(DEF_DF_UNOP |sin_DF| SIN) 347(DEF_DF_UNOP |cos_DF| COS) 348(DEF_DF_UNOP |tan_DF| TAN) 349(DEF_DF_UNOP |atan_DF| ATAN) 350(DEF_DF_UNOP |sinh_DF| SINH) 351(DEF_DF_UNOP |cosh_DF| COSH) 352(DEF_DF_UNOP |tanh_DF| TANH) 353 354;;; Machine integer operations 355 356(defmacro DEF_SI_BINOP (name op) 357 `(defmacro ,name (x y) `(the fixnum (,',op (the fixnum ,x) 358 (the fixnum ,y))))) 359(DEF_SI_BINOP |add_SI| +) 360(DEF_SI_BINOP |sub_SI| -) 361(DEF_SI_BINOP |mul_SI| *) 362(DEF_SI_BINOP |min_SI| min) 363(DEF_SI_BINOP |max_SI| max) 364(DEF_SI_BINOP |rem_SI| rem) 365(DEF_SI_BINOP |quo_SI_aux| truncate) 366(DEF_SI_BINOP |lshift_SI| ash) 367(DEF_SI_BINOP |and_SI| logand) 368(DEF_SI_BINOP |or_SI| logior) 369(DEF_SI_BINOP |xor_SI| logxor) 370(defmacro |quo_SI|(a b) `(values (|quo_SI_aux| ,a ,b))) 371 372(defmacro DEF_SI_UNOP (name op) 373 `(defmacro ,name (x) `(the fixnum (,',op (the fixnum ,x))))) 374 375(DEF_SI_UNOP |minus_SI| -) 376(DEF_SI_UNOP |abs_SI| abs) 377(DEF_SI_UNOP |inc_SI| 1+) 378(DEF_SI_UNOP |dec_SI| 1-) 379(DEF_SI_UNOP |not_SI| lognot) 380 381(defmacro DEF_SI_ARG_BINOP (name op) 382 `(defmacro ,name (x y) `(,',op (the fixnum ,x) (the fixnum ,y)))) 383 384(DEF_SI_ARG_BINOP |eql_SI| eql) 385(DEF_SI_ARG_BINOP |less_SI| <) 386(DEF_SI_ARG_BINOP |greater_SI| >) 387 388(defmacro DEF_SI_ARG_UNOP (name op) 389 `(defmacro ,name (x) `(,',op (the fixnum ,x)))) 390 391(DEF_SI_ARG_UNOP |zero?_SI| zerop) 392(DEF_SI_ARG_UNOP |negative?_SI| minusp) 393(DEF_SI_ARG_UNOP |odd?_SI| oddp) 394 395; Small finite field operations 396; 397;; following macros assume 0 <= x,y < z 398;; qsaddmod additionally assumes that rsum has correct value even 399;; when (x + y) exceeds range of a fixnum. This is true if 400;; fixnums use modular arithmetic with no overflow checking, 401;; but according to ANSI Lisp the result is undefined in 402;; such case. 403 404(defmacro |addmod_SI| (x y z) 405 `(let* ((sum (|add_SI| ,x ,y)) 406 (rsum (|sub_SI| sum ,z))) 407 (if (|negative?_SI| rsum) sum rsum))) 408 409(defmacro |submod_SI| (x y z) 410 `(let ((dif (|sub_SI| ,x ,y))) 411 (if (|negative?_SI| dif) (|add_SI| dif ,z) dif))) 412 413(defmacro |mulmod_SI| (x y z) `(rem (* (the fixnum ,x) (the fixnum ,y)) 414 ,z)) 415 416;;; Double precision arrays and matrices 417 418(defmacro MAKE_DOUBLE_VECTOR (n) 419 `(make-array (list ,n) :element-type 'double-float)) 420 421(defmacro MAKE_DOUBLE_VECTOR1 (n s) 422 `(make-array (list ,n) :element-type 'double-float :initial-element ,s)) 423 424(defmacro DELT(v i) 425 `(aref (the (simple-array double-float (*)) ,v) ,i)) 426 427(defmacro DSETELT(v i s) 428 `(setf (aref (the (simple-array double-float (*)) ,v) ,i) 429 ,s)) 430 431(defmacro DLEN(v) 432 `(length (the (simple-array double-float (*)) ,v))) 433 434(defmacro MAKE_DOUBLE_MATRIX (n m) 435 `(make-array (list ,n ,m) :element-type 'double-float)) 436 437(defmacro MAKE_DOUBLE_MATRIX1 (n m s) 438 `(make-array (list ,n ,m) :element-type 'double-float 439 :initial-element ,s)) 440 441(defmacro DAREF2(v i j) 442 `(aref (the (simple-array double-float (* *)) ,v) ,i ,j)) 443 444(defmacro DSETAREF2(v i j s) 445 `(setf (aref (the (simple-array double-float (* *)) ,v) ,i ,j) 446 ,s)) 447 448(defmacro DANROWS(v) 449 `(array-dimension (the (simple-array double-float (* *)) ,v) 0)) 450 451(defmacro DANCOLS(v) 452 `(array-dimension (the (simple-array double-float (* *)) ,v) 1)) 453 454;;; We implement complex array as arrays of doubles -- each 455;;; complex number occupies two positions in the real 456;;; array. 457 458(defmacro MAKE_CDOUBLE_VECTOR (n) 459 `(make-array (list (* 2 ,n)) :element-type 'double-float)) 460 461(defmacro CDELT(ov oi) 462 (let ((v (gensym)) 463 (i (gensym))) 464 `(let ((,v ,ov) 465 (,i ,oi)) 466 (cons 467 (aref (the (simple-array double-float (*)) ,v) (* 2 ,i)) 468 (aref (the (simple-array double-float (*)) ,v) (+ (* 2 ,i) 1)))))) 469 470(defmacro CDSETELT(ov oi os) 471 (let ((v (gensym)) 472 (i (gensym)) 473 (s (gensym))) 474 `(let ((,v ,ov) 475 (,i ,oi) 476 (,s ,os)) 477 (setf (aref (the (simple-array double-float (*)) ,v) (* 2 ,i)) 478 (car ,s)) 479 (setf (aref (the (simple-array double-float (*)) ,v) (+ (* 2 ,i) 1)) 480 (cdr ,s)) 481 ,s))) 482 483(defmacro CDLEN(v) 484 `(truncate (length (the (simple-array double-float (*)) ,v)) 2)) 485 486(defmacro MAKE_CDOUBLE_MATRIX (n m) 487 `(make-array (list ,n (* 2 ,m)) :element-type 'double-float)) 488 489(defmacro CDAREF2(ov oi oj) 490 (let ((v (gensym)) 491 (i (gensym)) 492 (j (gensym))) 493 `(let ((,v ,ov) 494 (,i ,oi) 495 (,j ,oj)) 496 (cons 497 (aref (the (simple-array double-float (* *)) ,v) ,i (* 2 ,j)) 498 (aref (the (simple-array double-float (* *)) ,v) 499 ,i (+ (* 2 ,j) 1)))))) 500 501(defmacro CDSETAREF2(ov oi oj os) 502 (let ((v (gensym)) 503 (i (gensym)) 504 (j (gensym)) 505 (s (gensym))) 506 `(let ((,v ,ov) 507 (,i ,oi) 508 (,j ,oj) 509 (,s ,os)) 510 (setf (aref (the (simple-array double-float (* *)) ,v) ,i (* 2 ,j)) 511 (car ,s)) 512 (setf (aref (the (simple-array double-float (* *)) ,v) 513 ,i (+ (* 2 ,j) 1)) 514 (cdr ,s)) 515 ,s))) 516 517(defmacro CDANROWS(v) 518 `(array-dimension (the (simple-array double-float (* *)) ,v) 0)) 519 520(defmacro CDANCOLS(v) 521 `(truncate 522 (array-dimension (the (simple-array double-float (* *)) ,v) 1) 2)) 523 524 525(defstruct (SPAD_KERNEL 526 (:print-function 527 (lambda (p s k) 528 (format s "#S~S" (list 529 'SPAD_KERNEL 530 :OP (SPAD_KERNEL-OP p) 531 :ARG (SPAD_KERNEL-ARG p) 532 :NEST (SPAD_KERNEL-NEST p)))))) 533 OP ARG NEST (POSIT 0)) 534 535(defmacro SET_SPAD_KERNEL_POSIT(s p) `(setf (SPAD_KERNEL-POSIT ,s) ,p)) 536 537(defun |makeSpadKernel|(o a n) (MAKE-SPAD_KERNEL :OP o :ARG a :NEST n)) 538 539; Hashtable accessors 540 541(defmacro HGET (table key) 542 `(gethash ,key ,table)) 543 544(defmacro HGET2 (table key default) 545 `(gethash ,key ,table ,default)) 546 547(defmacro HPUT(table key value) `(setf (gethash ,key ,table) ,value)) 548 549(defmacro HREM (table key) `(remhash ,key ,table)) 550 551; Misc operations 552 553(defmacro |qset_first|(l x) `(SETF (CAR (the cons ,l)) ,x)) 554 555(defmacro |qset_rest|(l x) `(SETF (CDR (the cons ,l)) ,x)) 556 557(defmacro setelt (vec ind val) `(setf (elt ,vec ,ind) ,val)) 558 559(defmacro pairp (x) `(consp ,x)) 560 561(defmacro qcar (x) `(car (the cons ,x))) 562 563(defmacro qcdr (x) `(cdr (the cons ,x))) 564 565(defmacro qcaar (x) 566 `(car (the cons (car (the cons ,x))))) 567 568(defmacro qcadr (x) 569 `(car (the cons (cdr (the cons ,x))))) 570 571(defmacro qcdar (x) 572 `(cdr (the cons (car (the cons ,x))))) 573 574(defmacro qcddr (x) 575 `(cdr (the cons (cdr (the cons ,x))))) 576 577;; qeqcar should be used when you know the first arg is a pair 578;; the second arg should either be a literal fixnum or a symbol 579;; the car of the first arg is always of the same type as the second 580 581(defmacro qeqcar (x y) 582 (cond ((typep y 'fixnum) `(eql (the fixnum (qcar ,x)) (the fixnum ,y))) 583 ((symbolp y) `(eq (qcar ,x) ,y)) 584 (t (BREAK)))) 585 586(defmacro qcsize (x) 587 `(the fixnum (length (the #-(or :ecl :gcl)simple-string 588 #+(or :ecl :gcl)string ,x)))) 589 590(defmacro qrefelt (vec ind) `(svref ,vec ,ind)) 591 592(defmacro qrplaca (a b) `(rplaca (the cons ,a) ,b)) 593 594(defmacro qrplacd (a b) `(rplacd (the cons ,a) ,b)) 595 596(defmacro qsetrefv (vec ind val) 597 `(setf (svref ,vec (the fixnum ,ind)) ,val)) 598 599(defmacro qsetvelt (vec ind val) 600 `(setf (svref ,vec (the fixnum ,ind)) ,val)) 601 602(defmacro qvelt (vec ind) `(svref ,vec (the fixnum ,ind))) 603 604(defmacro qvmaxindex (x) 605 `(the fixnum (1- (the fixnum (length (the simple-vector ,x)))))) 606 607(defmacro qvsize (x) 608 `(the fixnum (length (the simple-vector ,x)))) 609 610(defmacro eqcar (x y) 611 (if (atom x) 612 `(and (consp ,x) (eql (qcar ,x) ,y)) 613 (let ((xx (gensym))) 614 `(let ((,xx ,x)) 615 (and (consp ,xx) (eql (qcar ,xx) ,y)))))) 616 617(defmacro |bool_to_bit| (b) `(if ,b 1 0)) 618 619(defmacro |bit_to_bool| (b) `(eql ,b 1)) 620 621(defmacro ELT_BVEC (bv i) `(sbit ,bv ,i)) 622(defmacro SETELT_BVEC (bv i x) `(setf (sbit ,bv ,i) ,x)) 623(defmacro |size_BVEC| (bv) `(size ,bv)) 624 625(defun |is_BVEC| (bv) (simple-bit-vector-p bv)) 626 627; macros needed for Spad: 628 629(defun |TranslateTypeSymbol| (ts typeOrValue) 630 (let ((typDecl (assoc (car (cdr ts)) 631 '(((|Void|) (null nil)) 632 ((|SingleInteger|) (fixnum 0)) 633 ((|String|) (string "")) 634 ((|Boolean|) (BOOLEAN nil)) 635 ((|DoubleFloat|) (DOUBLE-FLOAT 0.0d0))) 636 :test #'equal 637 ))) 638 (if typDecl (setf typDecl (car (cdr typDecl))) 639 (return-from |TranslateTypeSymbol| (list (car ts)))) 640 (cons (car ts) (if typeOrValue (cdr typDecl) (car typDecl))))) 641 642(defun |GetLispType| (ts) 643 (|TranslateTypeSymbol| ts nil)) 644 645(defun |GetLispValue| (ts) 646 (|TranslateTypeSymbol| ts 't)) 647 648(defun |MakeDeclarations| (typSyms) 649 (let* ((tranTypSyms (mapcar #'|GetLispType| typSyms)) 650 (lispTypSyms (remove-if-not #'cdr tranTypSyms))) 651 (mapcar #'(lambda (ts) `(declare (type ,(cdr ts) ,(car ts)))) lispTypSyms))) 652 653(defun |MakeInitialValues| (typSyms) 654 (let ((initVals (mapcar #'|GetLispValue| typSyms))) 655 (mapcar #'(lambda (v) (if (endp (cdr v)) (car v) v)) initVals))) 656 657(defmacro SDEFUN (name args body) 658 (let ((vars (mapcar #'car args)) 659 (decls (|MakeDeclarations| (butlast args)))) 660 `(defun ,name ,vars ,@decls ,body))) 661 662(defmacro SPROG (vars &rest statements) 663 (let ((names (|MakeInitialValues| vars)) 664 (decls (|MakeDeclarations| vars))) 665 `(block nil (let ,names ,@decls ,@statements)))) 666 667(defmacro EXIT (&rest value) `(return-from SEQ ,@value)) 668 669(defmacro SEQ (&rest form) 670 (let* ((body (reverse form)) 671 (val `(return-from seq ,(pop body)))) 672 (nsubstitute '(progn) nil body) ;don't treat NIL as a label 673 `(block seq (tagbody ,@(nreverse body) ,val)))) 674 675(defmacro LETT (var val &rest L) 676 (COND 677 (|$QuickLet| `(SETQ ,var ,val)) 678 (|$compilingMap| 679 ;; map tracing 680 `(PROGN 681 (SETQ ,var ,val) 682 (COND (|$letAssoc| 683 (|mapLetPrint| ,(MKQ var) 684 ,var 685 (QUOTE ,(IFCAR L)))) 686 ('T ,var)))) 687 ;; used for LETs in SPAD code --- see devious trick in COMP-TRAN-1 688 ((ATOM var) 689 `(PROGN 690 (SETQ ,var ,val) 691 (IF |$letAssoc| 692 ,(cond ((null (cdr l)) 693 `(|letPrint| ,(MKQ var) ,var (QUOTE ,(IFCAR L)))) 694 ((and (eqcar (car l) 'SPADCALL) (= (length (car l)) 3)) 695 `(|letPrint3| ,(MKQ var) ,var ,(third (car l)) 696 (QUOTE ,(IFCAR (IFCDR L))))) 697 (t `(|letPrint2| ,(MKQ var) ,(car l) 698 (QUOTE ,(IFCAR (IFCDR L))))))) 699 ,var)) 700 ('T (ERROR "Cannot compileLET construct")))) 701 702(defmacro SPADLET (A B) 703 (if (ATOM A) `(SETQ ,A ,B) 704 (BREAK))) 705 706(defmacro SPADCALL (&rest L) 707 (let ((args (butlast l)) 708 (fn (car (last l))) 709 (gi (gensym))) 710 ;; (values t) indicates a single return value 711 `(let ((,gi ,fn)) 712 (the (values t) 713 (funcall 714 (the function (car ,gi)) 715 ,@args 716 (cdr ,gi)))))) 717 718(defmacro SPADMAP(&rest args) `'(SPADMAP ,@args)) 719 720(defmacro |finally|(x y) `(unwind-protect ,x ,y)) 721 722(defmacro |spadConstant| (dollar n) 723 `(SPADCALL (svref ,dollar (the fixnum ,n)))) 724 725(defmacro |SPADfirst| (l) 726 (let ((tem (gensym))) 727 `(let ((,tem ,l)) (if ,tem (car ,tem) (first_error))))) 728 729(defun first_error () (error "Cannot take first of an empty list")) 730 731(defmacro |dispatchFunction| (name) `(FUNCTION ,name)) 732 733(defmacro |Record| (&rest args) 734 (list '|Record0| 735 (cons 'LIST 736 (mapcar #'(lambda (x) (list 'CONS (MKQ (CADR x)) (CADDR x))) 737 args)))) 738 739(defmacro |Enumeration| (&rest args) 740 (cons '|Enumeration0| 741 (mapcar #'(lambda (x) (list 'QUOTE x)) args))) 742 743;;; Used for Record arguments 744(defmacro |:| (tag expr) `(LIST '|:| ,(MKQ tag) ,expr)) 745 746(defmacro |Zero|() 0) 747(defmacro |One|() 1) 748 749;;; range tests and assertions 750 751(defmacro |assert| (x y) `(IF (NULL ,x) (|error| ,y))) 752 753(defmacro |check_subtype2| (pred submode mode val) 754 `(|assert| ,pred (|coerce_failure_msg| ,val ,submode ,mode))) 755 756(defmacro |check_union2| (pred branch umode val) 757 `(|assert| ,pred (|check_union_failure_msg| ,val ,branch ,umode))) 758 759;;; Needed by interpreter 760(defmacro REPEAT (&rest L) (|expandREPEAT| L)) 761(defmacro COLLECT (&rest L) (|expandCOLLECT| L)) 762 763;;; Misc 764 765(defmacro |rplac| (x y) `(setf ,x ,y)) 766 767(defmacro |do| (&rest args) (CONS 'PROGN args)) 768 769;;; Support for double hashing tables 770;;; Double hashing hash tables need two distinct values. 771;;; VACANT - a marker for a free position that has never been used 772;;; DELETED - a marker for a position that has been used but is now 773;;; available for a new entry 774(defvar HASHTABLEVACANT (gensym)) 775(defvar HASHTABLEDELETED (gensym)) 776 777;;; Support for re-seeding the lisp random number generator. 778(defun SEEDRANDOM () (setf *random-state* (make-random-state t))) 779