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