source: branches/working-0710/ccl/compiler/optimizers.lisp @ 7383

Last change on this file since 7383 was 7383, checked in by gb, 12 years ago

Inline more.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 68.4 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17; Optimizers.lisp - compiler optimizers
18
19(in-package "CCL")
20
21(eval-when (eval compile)
22  (require'backquote)
23  (require'lispequ)
24  (require "ARCH"))
25
26(declaim (special *nx-can-constant-fold* *nx-synonyms*))
27
28(defvar *dont-find-class-optimize* nil) ; t means dont
29
30#|
31;;; can-constant-fold had a bug in the way it called #'proclaim-inline
32|#
33
34;;; There seems to be some confusion about what #'proclaim-inline does.
35;;; The value of the alist entry in *nx-proclaimed-inline* indicates
36;;; whether or not the compiler is allowed to use any special knowledge
37;;; about the symbol in question.  That's a necessary but not sufficient
38;;; condition to enable inline expansion; that's governed by declarations
39;;; in the compile-time environment.
40;;; If someone observed a symptom whereby calling CAN-CONSTANT-FOLD
41;;; caused unintended inline-expansion, the bug's elsewhere ...
42;;; The bug is that nx-declared-inline-p calls proclaimed-inline-p
43;;;  which looks at what proclaim-inline sets.  Presumably, that
44;;;  means that someone fixed it because it showed evidence of
45;;;  being broken.
46;;; The two concepts (the compiler should/should not make assumptions about
47;;;  the signature of known functions, the compiler should/should not arrange
48;;;  to keep the lambda expression around) need to be sorted out.
49
50(defun can-constant-fold (names &aux handler inlines)
51  (dolist (name names)
52    (if (atom name)
53      (setq handler nil)
54      (setq handler (cdr name) name (car name)))
55    (when (and handler (not (eq handler 'fold-constant-subforms)))
56      (warn "Unknown constant-fold handler : ~s" handler)
57      (setq handler nil))
58    (let* ((bits (%symbol-bits name)))
59      (declare (fixnum bits))
60      (%symbol-bits name (logior 
61                          (if handler (logior (ash 1 $sym_fbit_fold_subforms) (ash 1 $sym_fbit_constant_fold))
62                              (ash 1 $sym_fbit_constant_fold))
63                          bits)))
64     (push name inlines))
65  '(apply #'proclaim-inline t inlines)
66)
67
68;;; There's a bit somewhere.  This is very partial.  Should be a bit
69;;; somewhere, there are too many of these to keep on a list.
70(can-constant-fold '(specfier-type %ilsl %ilsr 1- 1+ eql eq
71                     byte make-point - / (+ . fold-constant-subforms) (* . fold-constant-subforms) ash character
72                     char-code code-char lsh
73                     (logior . fold-constant-subforms) (logand . fold-constant-subforms)
74                     (logxor . fold-constant-subforms) logcount logorc2 listp consp expt
75                     logorc1 logtest lognand logeqv lognor lognot logandc2 logandc1
76                     numerator denominator ldb-test byte-position byte-size isqrt gcd
77                     floor mod truncate rem round boole max min ldb dpb mask-field deposit-field
78                     length aref svref char schar bit sbit getf identity list-length
79                     car cdr cadr cddr nth nthcdr last load-byte deposit-byte byte-mask
80                     member search count position assoc rassoc integer-length
81                         float not null char-int expt abs))
82
83(defun %binop-cassoc (call)
84  (unless (and (cddr call) (null (cdr (%cddr call))))
85    (return-from %binop-cassoc call))
86  (let ((func (%car call))
87        (arg1 (%cadr call))
88        (arg2 (%caddr call))
89        (val))
90    (cond ((and (fixnump arg1) (fixnump arg2))
91           (funcall func arg1 arg2))
92          ((or (fixnump arg1) (fixnump arg2))
93           (if (fixnump arg2) (psetq arg1 arg2 arg2 arg1))
94           (if (and (consp arg2)
95                    (eq (%car arg2) func)
96                    (cddr arg2)
97                    (null (cdr (%cddr arg2)))
98                    (or (fixnump (setq val (%cadr arg2)))
99                        (fixnump (setq val (%caddr arg2)))))
100             (list func
101                   (funcall func arg1 val)
102                   (if (eq val (%cadr arg2)) (%caddr arg2) (%cadr arg2)))
103             call))
104          (t call))))
105
106(defun fixnumify (args op &aux (len (length args)))
107  (if (eq len 2)
108    (cons op args)
109    (list op (%car args) (fixnumify (%cdr args) op))))
110
111(defun generic-to-fixnum-n (call env op &aux (args (%cdr call)) targs)
112  (block nil
113    (if (and (%i> (length args) 1)
114             (and (nx-trust-declarations env)
115                  (or (neq op '%i+) (subtypep *nx-form-type* 'fixnum))))
116      (if (dolist (arg args t)
117            (if (nx-form-typep arg 'fixnum env)
118              (push arg targs)
119              (return)))
120        (return 
121         (fixnumify (nreverse targs) op))))
122    call))
123
124;;; True if arg is an alternating list of keywords and args,
125;;; only recognizes keywords in keyword package.
126;;; Historical note: this used to try to ensure that the
127;;; keyword appeared at most once.  Why ? (Even before
128;;; destructuring, pl-search/getf would have dtrt.)
129(defun constant-keywords-p (keys)
130  (when (plistp keys)
131    (while keys
132      (unless (keywordp (%car keys))
133        (return-from constant-keywords-p nil))
134      (setq keys (%cddr keys)))
135    t))
136
137(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly)
138  (if (null keys)
139    `(,default ,item ,list)
140     (if (constant-keywords-p keys)
141        (destructuring-bind (&key (test nil test-p)
142                                  (test-not nil test-not-p)
143                                  (key nil key-p))
144                            keys
145          (declare (ignore test-not))
146          (if (and test-p 
147                   (not test-not-p)
148                   (or (not key-p)
149                       (and (consp key)
150                            (consp (%cdr key))
151                            (null (%cddr key))
152                            (or (eq (%car key) 'function)
153                                (eq (%car key) 'quote))
154                            (eq (%cadr key) 'identity)))
155                   (consp test) 
156                   (consp (%cdr test))
157                   (null (%cddr test))
158                   (or (eq (%car test) 'function)
159                       (eq (%car test) 'quote)))
160            (let* ((testname (%cadr test))
161                   (reduced (cdr (assoc testname alist))))
162              (if reduced
163                `(,reduced ,item ,list)
164                `(,testonly ,item ,list ,test))))))))
165
166
167(defun eql-iff-eq-p (thing env)
168  (if (quoted-form-p thing)
169    (setq thing (%cadr thing))
170    (if (not (self-evaluating-p thing))
171        (return-from eql-iff-eq-p
172          (or (nx-form-typep thing  'symbol env)
173              (nx-form-typep thing 'character env)
174              (nx-form-typep thing
175                             '(or fixnum
176                               #+64-bit-target single-float
177                               symbol character
178                               (and (not number) (not macptr))) env)))))
179  (or (fixnump thing) #+64-bit-target (typep thing 'single-float)
180      (symbolp thing) (characterp thing)
181      (and (not (numberp thing)) (not (macptrp thing)))))
182
183(defun equal-iff-eql-p (thing env)
184  (if (quoted-form-p thing)
185    (setq thing (%cadr thing))
186    (if (not (self-evaluating-p thing))
187      (return-from equal-iff-eql-p
188        (nx-form-typep thing
189                       '(and (not cons) (not string) (not bit-vector) (not pathname)) env))))
190  (not (typep thing '(or cons string bit-vector pathname))))
191
192
193(defun fold-constant-subforms (call env)
194    (let* ((constants nil)
195           (forms nil))
196      (declare (list constants forms))
197      (dolist (form (cdr call))
198        (setq form (nx-transform form env))
199        (if (numberp form)
200          (setq constants (%temp-cons form constants))
201          (setq forms (%temp-cons form forms))))
202      (if constants
203        (let* ((op (car call))
204               (constant (if (cdr constants) (handler-case (apply op constants)
205                                               (error (c) (declare (ignore c)) 
206                                                      (return-from fold-constant-subforms (values call t))))
207                             (car constants))))
208          (values (if forms (cons op (cons constant (reverse forms))) constant) t))
209        (values call nil))))
210
211;;; inline some, etc. in some cases
212;;; in all cases, add dynamic-extent declarations
213(defun some-xx-transform (call env)
214  (destructuring-bind (func predicate sequence &rest args) call
215    (multiple-value-bind (func-constant end-value loop-test)
216                         (case func
217                           (some (values $some nil 'when))
218                           (notany (values $notany t 'when))
219                           (every (values $every t 'unless))
220                           (notevery (values $notevery nil 'unless)))
221      (if args
222        (let ((func-sym (gensym))
223              (seq-sym (gensym))
224              (list-sym (gensym)))
225          `(let ((,func-sym ,predicate)
226                 (,seq-sym ,sequence)
227                 (,list-sym (list ,@args)))
228             (declare (dynamic-extent ,func-sym ,list-sym ,seq-sym))
229             (some-xx-multi ,func-constant ,end-value ,func-sym ,seq-sym ,list-sym)))
230        (let ((loop-function (nx-form-sequence-iterator sequence env)))
231          ;; inline if we know the type of the sequence and if
232          ;; the predicate is a lambda expression
233          ;; otherwise, it blows up the code for not much gain
234          (if (and loop-function
235                   (function-form-p predicate)
236                   (lambda-expression-p (second predicate)))
237            (let ((elt-var (gensym)))
238              (case func
239                (some
240                 `(,loop-function (,elt-var ,sequence ,end-value)
241                                  (let ((result (funcall ,predicate ,elt-var)))
242                                    (when result (return result)))))
243                ((every notevery notany)
244                 `(,loop-function (,elt-var ,sequence ,end-value)
245                                  (,loop-test (funcall ,predicate ,elt-var)
246                                              (return ,(not end-value)))))))
247            (let ((func-sym (gensym))
248                  (seq-sym (gensym)))
249              `(let ((,func-sym ,predicate)
250                     (,seq-sym ,sequence))
251                 (declare (dynamic-extent ,func-sym ,seq-sym))
252                 (some-xx-one ,func-constant ,end-value ,func-sym ,seq-sym)))))))))
253
254
255;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
256;;;
257;;; The new (roughly alphabetical) order.
258;;;
259;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
260
261;;; Compiler macros on functions can assume that their arguments have
262;;; already been transformed.
263
264
265(defun transform-real-n-ary-comparision (whole binary-name)
266  (destructuring-bind (n0 &optional (n1 0 n1-p) &rest more) (cdr whole)
267    (if more
268      (if (cdr more)
269        whole
270        (let* ((n2 (car more))
271               (n (gensym)))
272          `(let* ((,n ,n0))
273            (if (,binary-name ,n (setq ,n ,n1))
274              (,binary-name ,n ,n2)))))
275      (if (not n1-p)
276        `(require-type ,n0 'real)
277        `(,binary-name ,n0 ,n1)))))
278
279
280
281(define-compiler-macro < (&whole whole &rest ignore)
282  (declare (ignore ignore))
283  (transform-real-n-ary-comparision whole '<-2))
284
285(define-compiler-macro > (&whole whole &rest ignore)
286  (declare (ignore ignore))
287  (transform-real-n-ary-comparision whole '>-2))
288
289(define-compiler-macro <= (&whole whole &rest ignore)
290  (declare (ignore ignore))
291  (transform-real-n-ary-comparision whole '<=-2))
292
293(define-compiler-macro >= (&whole whole &rest ignore)
294  (declare (ignore ignore))
295  (transform-real-n-ary-comparision whole '>=-2))
296
297
298(define-compiler-macro 1- (x)
299  `(- ,x 1))
300
301(define-compiler-macro 1+ (x)
302  `(+ ,x 1))
303
304(define-compiler-macro append  (&whole call 
305                                       &optional arg0 
306                                       &rest 
307                                       (&whole tail 
308                                               &optional (junk nil arg1-p) 
309                                               &rest more))
310  ;(append (list x y z) A) -> (list* x y z A)
311  (if (and arg1-p
312           (null more)
313           (consp arg0)
314           (eq (%car arg0) 'list))
315    (cons 'list* (append (%cdr arg0) tail))
316    (if (and arg1-p (null more))
317      `(append-2 ,arg0 ,junk)
318      call)))
319
320(define-compiler-macro apply  (&whole call &environment env fn arg0 &rest args)
321  (let ((original-fn fn))
322    (if (and arg0 
323             (null args)
324             (consp fn)
325             (eq (%car fn) 'function)
326             (null (cdr (%cdr fn)))
327             (consp (setq fn (%cadr fn)))
328             (eq (%car fn) 'lambda))
329      (destructuring-bind (lambda-list &body body) (%cdr fn)
330        `(destructuring-bind ,lambda-list ,arg0 ,@body))
331      (let ((last (%car (last (push arg0 args)))))
332        (if (and (consp last) (memq (%car last) '(cons list* list)))
333          (cons (if (eq (%car last) 'list) 'funcall 'apply)
334                (cons
335                 original-fn
336                 (nreconc (cdr (reverse args)) (%cdr last))))
337          call)))))
338
339
340
341(define-compiler-macro assoc (&whole call item list &rest keys)
342  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql .asseql) (equal . assequal)) 'assoc-test)
343      call))
344
345(define-compiler-macro assequal (&whole call &environment env item list)
346  (if (or (equal-iff-eql-p item env)
347          (and (quoted-form-p list)
348               (proper-list-p (%cadr list))
349               (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list))))
350    `(asseql ,item ,list)
351    call))
352 
353(define-compiler-macro asseql (&whole call &environment env item list)
354  (if (or (eql-iff-eq-p item env)
355          (and (quoted-form-p list)
356               (proper-list-p (%cadr list))
357               (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list))))
358    `(assq ,item ,list)
359    call))
360
361(define-compiler-macro assq (item list)
362  (let* ((itemx (gensym))
363         (listx (gensym))
364         (pair (gensym)))
365    `(let* ((,itemx ,item)
366            (,listx ,list))
367      (dolist (,pair ,listx)
368        (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair))))))
369
370(define-compiler-macro caar (form)
371  `(car (car ,form)))
372
373(define-compiler-macro cadr (form)
374  `(car (cdr ,form)))
375
376(define-compiler-macro cdar (form)
377  `(cdr (car ,form)))
378
379(define-compiler-macro cddr (form)
380  `(cdr (cdr ,form)))
381
382(define-compiler-macro caaar (form)
383  `(car (caar ,form)))
384
385(define-compiler-macro caadr (form)
386  `(car (cadr ,form)))
387
388(define-compiler-macro cadar (form)
389  `(car (cdar ,form)))
390
391(define-compiler-macro caddr (form)
392  `(car (cddr ,form)))
393
394(define-compiler-macro cdaar (form)
395  `(cdr (caar ,form)))
396
397(define-compiler-macro cdadr (form)
398  `(cdr (cadr ,form)))
399
400(define-compiler-macro cddar (form)
401  `(cdr (cdar ,form)))
402
403(define-compiler-macro cdddr (form)
404  `(cdr (cddr ,form)))
405
406(define-compiler-macro caaaar (form)
407  `(car (caaar ,form)))
408 
409(define-compiler-macro caaadr (form)
410  `(car (caadr ,form)))
411
412(define-compiler-macro caadar (form)
413  `(car (cadar ,form)))
414
415(define-compiler-macro caaddr (form)
416  `(car (caddr ,form)))
417
418(define-compiler-macro cadaar (form)
419  `(car (cdaar ,form)))
420
421(define-compiler-macro cadadr (form)
422  `(car (cdadr ,form)))
423
424(define-compiler-macro caddar (form)
425  `(car (cddar ,form)))
426
427(define-compiler-macro cadddr (form)
428  `(car (cdddr ,form)))
429
430(define-compiler-macro cdaaar (form)
431  `(cdr (caaar ,form)))
432 
433(define-compiler-macro cdaadr (form)
434  `(cdr (caadr ,form)))
435
436(define-compiler-macro cdadar (form)
437  `(cdr (cadar ,form)))
438
439(define-compiler-macro cdaddr (form)
440  `(cdr (caddr ,form)))
441
442(define-compiler-macro cddaar (form)
443  `(cdr (cdaar ,form)))
444
445(define-compiler-macro cddadr (form)
446  `(cdr (cdadr ,form)))
447
448(define-compiler-macro cdddar (form)
449  `(cdr (cddar ,form)))
450
451(define-compiler-macro cddddr (form)
452  `(cdr (cdddr ,form)))
453
454
455
456
457(define-compiler-macro cons (&whole call &environment env x y &aux dcall ddcall)
458   (if (consp (setq dcall y))
459     (cond
460      ((or (eq (%car dcall) 'list) (eq (%car dcall) 'list*))
461       ;(CONS A (LIST[*] . args)) -> (LIST[*] A . args)
462       (list* (%car dcall) x (%cdr dcall)))
463      ((or (neq (%car dcall) 'cons) (null (cddr dcall)) (cdddr dcall))
464       call)
465      ((null (setq ddcall (%caddr dcall)))
466       ;(CONS A (CONS B NIL)) -> (LIST A B)
467       `(list ,x ,(%cadr dcall)))
468      ((and (consp ddcall)
469            (eq (%car ddcall) 'cons)
470            (eq (list-length ddcall) 3))
471       ;(CONS A (CONS B (CONS C D))) -> (LIST* A B C D)
472       (list* 'list* x (%cadr dcall) (%cdr ddcall)))
473      (t call))
474     call))
475
476(define-compiler-macro dotimes (&whole call (i n &optional result) 
477                                       &body body
478                                       &environment env)
479  (multiple-value-bind (body decls) (parse-body body env)
480    (if (nx-form-typep (setq n (nx-transform n env)) 'fixnum env)
481        (let* ((limit (gensym))
482               (upper (if (constantp n) n most-positive-fixnum))
483               (top (gensym))
484               (test (gensym)))
485          `(let* ((,limit ,n) (,i 0))
486             ,@decls
487             (declare (fixnum ,limit)
488                      (type (integer 0 ,(if (<= upper 0) 0 `(,upper))) ,i)
489                      (unsettable ,i))
490             (block nil
491               (tagbody
492                 (go ,test)
493                 ,top
494                 ,@body
495                 (locally
496                   (declare (settable ,i))
497                   (setq ,i (1+ ,i)))
498                 ,test
499                 (when (< ,i ,limit) (go ,top)))
500               ,result)))
501        call)))
502
503(define-compiler-macro dpb (&whole call &environment env value byte integer)
504  (cond ((and (integerp byte) (> byte 0))
505         (if (integerp value)
506           `(logior ,(dpb value byte 0) (logand ,(lognot byte) ,integer))
507           `(deposit-field (ash ,value ,(byte-position byte)) ,byte ,integer)))
508        ((and (consp byte)
509              (eq (%car byte) 'byte)
510              (eq (list-length (%cdr byte)) 2))
511         `(deposit-byte ,value ,(%cadr byte) ,(%caddr byte) ,integer))
512        (t call)))
513
514(define-compiler-macro eql (&whole call &environment env v1 v2)
515  (if (or (eql-iff-eq-p v1 env) (eql-iff-eq-p v2 env))
516    `(eq ,v1 ,v2)
517    call))
518
519(define-compiler-macro every (&whole call &environment env &rest ignore)
520  (declare (ignore ignore))
521  (some-xx-transform call env))
522
523
524(define-compiler-macro identity (form) form)
525
526(define-compiler-macro if (&whole call test true &optional false &environment env)
527  (multiple-value-bind (test test-win) (nx-transform test env)
528    (multiple-value-bind (true true-win) (nx-transform true env)
529      (multiple-value-bind (false false-win) (nx-transform false env)
530        (if (or (quoted-form-p test) (self-evaluating-p test))
531          (if (eval test) 
532            true
533            false)
534          (if (or test-win true-win false-win)
535            `(if ,test ,true ,false)
536            call))))))
537
538(define-compiler-macro %ilsr (&whole call &environment env shift value)
539  (if (eql shift 0)
540    value
541    (if (eql value 0)
542      `(progn ,shift 0)
543      call)))
544
545
546(define-compiler-macro ldb (&whole call &environment env byte integer)
547   (cond ((and (integerp byte) (> byte 0))
548          (let ((size (byte-size byte))
549                (position (byte-position byte)))
550            (cond ((nx-form-typep integer 'fixnum env)
551                   `(logand ,(byte-mask size)
552                     (the fixnum (ash ,integer ,(- position)))))
553                  (t `(load-byte ,size ,position ,integer)))))
554         ((and (consp byte)
555               (eq (%car byte) 'byte)
556               (eq (list-length (%cdr byte)) 2))
557          (let ((size (%cadr byte))
558                (position (%caddr byte)))
559            (if (and (nx-form-typep integer 'fixnum env) (fixnump position))
560              ;; I'm not sure this is worth doing
561              `(logand (byte-mask ,size) (the fixnum (ash ,integer ,(- position))))
562              ;; this IS worth doing
563              `(load-byte ,size ,position ,integer))))
564         (t call)))
565
566(define-compiler-macro length (&whole call &environment env seq)
567  (if (nx-form-typep seq '(simple-array * (*)) env)
568    `(uvsize ,seq)
569    call))
570
571(define-compiler-macro let (&whole call (&optional (first nil first-p) &rest rest) &body body)
572  (if first-p
573    (if rest
574      call
575      `(let* (,first) ,@body))
576    `(locally ,@body)))
577
578(define-compiler-macro let* (&whole call (&rest bindings) &body body)
579  (if bindings
580    call
581    `(locally ,@body)))
582
583(define-compiler-macro list* (&whole call &environment env &rest rest  &aux (n (list-length rest)) last)
584  (cond ((%izerop n) nil)
585        ((null (setq last (%car (last call))))
586         (cons 'list (nreverse (cdr (reverse (cdr call))))))
587        ((and (consp last) (memq (%car last) '(list* list cons)))
588         (cons (if (eq (%car last) 'cons) 'list* (%car last))
589                                 (nreconc (cdr (reverse (cdr call))) (%cdr last))))
590        ((eq n 1) (list 'values last))
591        ((eq n 2) (cons 'cons (%cdr call)))
592        (t call)))
593
594
595
596;;;(CONS X NIL) is same size as (LIST X) and faster.
597(define-compiler-macro list  (&whole call &optional (first nil first-p) &rest more)
598  (if more
599    call
600    (if first-p
601      `(cons ,first nil))))
602
603
604(define-compiler-macro locally (&whole call &body body &environment env)
605  (multiple-value-bind (body decls) (parse-body body env nil)
606    (if decls
607      call
608      `(progn ,@body))))
609
610
611(defun target-element-type-type-keyword (typespec)
612  (let* ((ctype (ignore-errors (specifier-type `(array ,typespec)))))
613    (if (or (null ctype) (typep ctype 'unknown-ctype))
614      (progn
615        (nx1-whine :unknown-type-declaration typespec)
616        nil)
617      (funcall (arch::target-array-type-name-from-ctype-function
618                (backend-target-arch *target-backend*))
619               ctype))))
620
621(defun infer-array-type (dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)
622  (let* ((ctype (make-array-ctype :complexp (or displaced-to-p fill-pointer-p adjustable-p))))
623    (if (quoted-form-p dims)
624      (let* ((dims (nx-unquote dims)))
625        (if (listp dims)
626          (progn
627            (unless (every #'fixnump dims)
628              (warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims))
629            (setf (array-ctype-dimensions ctype) dims))
630          (progn
631            (unless (typep dims 'fixnum)
632              (warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims))
633            (setf (array-ctype-dimensions ctype) (list dims)))))
634      (if (atom dims)
635        (if (nx-form-typep dims 'fixnum env)
636          (setf (array-ctype-dimensions ctype)
637                (if (typep (setq dims (nx-transform dims env)) 'fixnum)
638                  (list dims)
639                  (list '*)))
640          (setf (array-ctype-dimensions ctype) '*))
641        (if (eq (car dims) 'list)
642          (setf (array-ctype-dimensions ctype)
643                (mapcar #'(lambda (d)
644                            (if (typep (setq d (nx-transform d env)) 'fixnum)
645                              d
646                              '*))
647                        (cdr dims)))
648          ;; Wimp out
649          (setf (array-ctype-dimensions ctype)
650                '*))))
651    (let* ((element-type (specifier-type (if element-type-p (nx-unquote element-type) t))))
652      (setf (array-ctype-element-type ctype) element-type)
653      (if (typep element-type 'unknown-ctype)
654        (setf (array-ctype-specialized-element-type ctype) *wild-type*)
655        (specialize-array-type ctype)))
656    (type-specifier ctype)))
657
658     
659     
660(define-compiler-macro make-array (&whole call &environment env dims &rest keys)
661  (if (constant-keywords-p keys)
662    (destructuring-bind (&key (element-type t element-type-p)
663                              (displaced-to () displaced-to-p)
664                              (displaced-index-offset () displaced-index-offset-p)
665                              (adjustable () adjustable-p)
666                              (fill-pointer () fill-pointer-p)
667                              (initial-element () initial-element-p)
668                              (initial-contents () initial-contents-p)) 
669        keys
670      (declare (ignorable element-type element-type-p
671                          displaced-to displaced-to-p
672                          displaced-index-offset displaced-index-offset-p
673                          adjustable adjustable-p
674                          fill-pointer fill-pointer-p
675                          initial-element initial-element-p
676                          initial-contents initial-contents-p))
677      (let* ((element-type-keyword nil)
678             (expansion 
679              (cond ((and initial-element-p initial-contents-p)
680                     (nx1-whine 'illegal-arguments call)
681                     call)
682                    (displaced-to-p
683                     (if (or initial-element-p initial-contents-p element-type-p)
684                       (comp-make-array-1 dims keys)
685                       (comp-make-displaced-array dims keys)))
686                    ((or displaced-index-offset-p 
687                         (not (constantp element-type))
688                         (null (setq element-type-keyword
689                                     (target-element-type-type-keyword
690                                      (eval element-type)))))
691                     (comp-make-array-1 dims keys))
692                    ((and (typep element-type-keyword 'keyword) 
693                          (nx-form-typep dims 'fixnum env) 
694                          (null (or adjustable fill-pointer initial-contents 
695                                    initial-contents-p))) 
696                     (if 
697                       (or (null initial-element-p) 
698                           (cond ((eql element-type-keyword :double-float-vector) 
699                                  (eql initial-element 0.0d0)) 
700                                 ((eql element-type-keyword :single-float-vector) 
701                                  (eql initial-element 0.0s0)) 
702                                 ((eql element-type :simple-string) 
703                                  (eql initial-element #\Null))
704                                 (t (eql initial-element 0))))
705                       `(allocate-typed-vector ,element-type-keyword ,dims) 
706                       `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element))) 
707                    (t                        ;Should do more here
708                     (comp-make-uarray dims keys (type-keyword-code element-type-keyword)))))
709             (type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)))
710        `(the ,type ,expansion)))
711       
712        call))
713
714(defun comp-make-displaced-array (dims keys)
715  (let* ((call-list (make-list 4 :initial-element nil))
716         (dims-var (make-symbol "DIMS"))
717         (let-list (comp-nuke-keys keys
718                                   '((:displaced-to 0)
719                                     (:fill-pointer 1)
720                                     (:adjustable 2)
721                                     (:displaced-index-offset 3))
722                                   call-list
723                                   `((,dims-var ,dims)))))
724
725    `(let ,let-list
726       (%make-displaced-array ,dims-var ,@call-list t))))
727
728(defun comp-make-uarray (dims keys subtype)
729  (if (null keys)
730    `(%make-simple-array ,subtype ,dims)
731    (let* ((call-list (make-list 6))
732           (dims-var (make-symbol "DIMS"))
733         (let-list (comp-nuke-keys keys
734                                   '((:adjustable 0)
735                                     (:fill-pointer 1)
736                                     (:initial-element 2 3)
737                                     (:initial-contents 4 5))
738                                   call-list
739                                   `((,dims-var ,dims)))))
740    `(let ,let-list
741       (make-uarray-1 ,subtype ,dims-var ,@call-list nil nil)))))
742
743(defun comp-make-array-1 (dims keys)
744  (let* ((call-list (make-list 10 :initial-element nil))
745         (dims-var (make-symbol "DIMS"))
746         (let-list (comp-nuke-keys keys                                   
747                                   '((:element-type 0 1)
748                                     (:displaced-to 2)
749                                     (:displaced-index-offset 3)
750                                     (:adjustable 4)
751                                     (:fill-pointer 5)
752                                     (:initial-element 6 7)
753                                     (:initial-contents 8 9))
754                                   call-list
755                                   `((,dims-var ,dims)))))
756    `(let ,let-list
757       (make-array-1 ,dims-var ,@call-list nil))))
758
759(defun comp-nuke-keys (keys key-list call-list &optional required-bindings)
760  ; side effects call list, returns a let-list
761  (let ((let-list (reverse required-bindings)))
762    (do ((lst keys (cddr lst)))
763        ((null lst) nil)
764      (let* ((key (car lst))
765             (val (cadr lst))
766             (ass (assq key key-list))
767             (vpos (cadr ass))
768             (ppos (caddr ass)))
769        (when ass
770          (when (not (constantp val))
771            (let ((gen (gensym)))
772              (setq let-list (cons (list gen val) let-list)) ; reverse him
773              (setq val gen)))
774          (rplaca (nthcdr vpos call-list) val)
775          (if ppos (rplaca (nthcdr ppos call-list) t)))))
776    (nreverse let-list)))
777
778(define-compiler-macro make-instance (&whole call class &rest initargs)
779  (if (and (listp class)
780           (eq (car class) 'quote)
781           (symbolp (cadr class))
782           (null (cddr class)))
783    `(%make-instance (load-time-value (find-class-cell ,class t))
784                     ,@initargs)
785    call))
786
787
788
789
790
791                                 
792
793(define-compiler-macro mapc  (&whole call fn lst &rest more)
794  (if more
795    call
796    (let* ((temp-var (gensym))
797           (elt-var (gensym))
798           (fn-var (gensym)))
799       `(let* ((,fn-var ,fn)
800               (,temp-var ,lst))
801          (dolist (,elt-var ,temp-var ,temp-var)
802            (funcall ,fn-var ,elt-var))
803          ))))
804
805(define-compiler-macro mapcar (&whole call fn lst &rest more)
806  (if more
807    call
808    (let* ((temp-var (gensym))
809           (result-var (gensym))
810           (elt-var (gensym))
811           (fn-var (gensym)))
812      `(let* ((,temp-var (cons nil nil))
813              (,result-var ,temp-var)
814              (,fn-var ,fn))
815         (declare (dynamic-extent ,temp-var)
816                  (type cons ,temp-var ,result-var))
817         (dolist (,elt-var ,lst (cdr ,result-var))
818           (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var)))))))))
819
820(define-compiler-macro member (&whole call item list &rest keys)
821  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test)
822      call))
823
824(define-compiler-macro memequal (&whole call &environment env item list)
825  (if (or (equal-iff-eql-p item env)
826          (and (quoted-form-p list)
827               (proper-list-p (%cadr list))
828               (every #'equal-iff-eql-p (%cadr list)) env))
829    `(memeql ,item ,list)
830    call))
831 
832(define-compiler-macro memeql (&whole call &environment env item list)
833  (if (or (eql-iff-eq-p item env)
834          (and (quoted-form-p list)
835               (proper-list-p (%cadr list))
836               (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list))))
837    `(memq ,item ,list)
838    call))
839
840(define-compiler-macro memq (&whole call &environment env item list)
841  ;;(memq x '(y)) => (if (eq x 'y) '(y))
842  ;;Would it be worth making a two elt list into an OR?  Maybe if
843  ;;optimizing for speed...
844   (if (and (or (quoted-form-p list)
845                (null list))
846            (null (cdr (%cadr list))))
847     (if list `(if (eq ,item ',(%caadr list)) ,list))
848     (let* ((x (gensym))
849            (tail (gensym)))
850       `(do* ((,x ,item)
851              (,tail ,list (cdr (the list ,tail))))
852         ((null ,tail))
853         (if (eq (car ,tail) ,x) (return ,tail))))))
854
855(define-compiler-macro minusp (x)
856  `(< ,x 0))
857
858(define-compiler-macro notany (&whole call &environment env &rest ignore)
859  (declare (ignore ignore))
860  (some-xx-transform call env))
861
862(define-compiler-macro notevery (&whole call &environment env &rest ignore)
863  (declare (ignore ignore))
864  (some-xx-transform call env))
865
866(define-compiler-macro nth  (&whole call &environment env count list)
867   (if (and (fixnump count)
868            (%i>= count 0)
869            (%i< count 3))
870     `(,(svref '#(car cadr caddr) count) ,list)
871     `(car (nthcdr ,count ,list))))
872
873(define-compiler-macro nthcdr (&whole call &environment env count list)
874  (if (and (fixnump count)
875           (%i>= count 0)
876           (%i< count 4)) 
877     (if (%izerop count)
878       `(require-type ,list 'list)
879       `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list))
880    (let* ((i (gensym))
881           (n (gensym))                 ; evaluation order
882           (tail (gensym)))
883      `(let* ((,n (require-type ,count 'unsigned-byte))
884              (,tail (require-type ,list 'list)))
885        (dotimes (,i ,n ,tail)
886          (unless (setq ,tail (cdr ,tail))
887            (return nil)))))))
888
889(define-compiler-macro plusp (x)
890  `(> ,x 0))
891
892(define-compiler-macro progn (&whole call &optional (first nil first-p) &rest rest)
893  (if first-p
894    (if rest call first)))
895
896;;; This isn't quite right... The idea is that (car (require-type foo
897;;; 'list)) ;can become just (<typechecking-car> foo) [regardless of
898;;; optimize settings], ;but I don't think this can be done just with
899;;; optimizers... For now, at least try to get it to become (%car
900;;; (<typecheck> foo)).
901(define-compiler-macro require-type (&whole call &environment env arg type)
902  (cond ((and (quoted-form-p type)
903              (setq type (%cadr type))
904              (not (typep (specifier-type type) 'unknown-ctype)))       
905         (cond ((nx-form-typep arg type env) arg)
906               ((eq type 'simple-vector)
907                `(the simple-vector (require-simple-vector ,arg)))
908               ((eq type 'simple-string)
909                `(the simple-string (require-simple-string ,arg)))
910               ((eq type 'integer)
911                `(the integer (require-integer ,arg)))
912               ((eq type 'fixnum)
913                `(the fixnum (require-fixnum ,arg)))
914               ((eq type 'real)
915                `(the real (require-real ,arg)))
916               ((eq type 'list)
917                `(the list (require-list ,arg)))
918               ((eq type 'character)
919                `(the character (require-character ,arg)))
920               ((eq type 'number)
921                `(the number (require-number ,arg)))
922               ((eq type 'symbol)
923                `(the symbol (require-symbol ,arg)))
924               ((type= (specifier-type type)
925                       (specifier-type '(signed-byte 8)))
926                `(the (signed-byte 8) (require-s8 ,arg)))               
927               ((type= (specifier-type type)
928                       (specifier-type '(unsigned-byte 8)))
929                `(the (unsigned-byte 8) (require-u8 ,arg)))
930               ((type= (specifier-type type)
931                       (specifier-type '(signed-byte 16)))
932                `(the (signed-byte 16) (require-s16 ,arg)))
933               ((type= (specifier-type type)
934                       (specifier-type '(unsigned-byte 16)))
935                `(the (unsigned-byte 16) (require-u16 ,arg)))               
936               ((type= (specifier-type type)
937                       (specifier-type '(signed-byte 32)))
938                `(the (signed-byte 32) (require-s32 ,arg)))
939               ((type= (specifier-type type)
940                       (specifier-type '(unsigned-byte 32)))
941                `(the (unsigned-byte 32) (require-u32 ,arg)))
942               ((type= (specifier-type type)
943                       (specifier-type '(signed-byte 64)))
944                `(the (signed-byte 64) (require-s64 ,arg)))
945               ((type= (specifier-type type)
946                       (specifier-type '(unsigned-byte 64)))
947                `(the (unsigned-byte 64) (require-u64 ,arg)))               
948               ((and (consp type)(memq (car type) '(signed-byte unsigned-byte integer)))
949                `(the ,type (%require-type-builtin ,arg 
950                                                   (load-time-value (find-builtin-cell ',type)))))
951               ((and (symbolp type)
952                     (let ((simpler (type-predicate type)))
953                       (if simpler `(the ,type (%require-type ,arg ',simpler))))))
954               ((and (symbolp type)(find-class type nil env))
955                  `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
956               (t call)))
957        (t call)))
958
959(define-compiler-macro proclaim (&whole call decl)
960   (if (and (quoted-form-p decl)
961            (eq (car (setq decl (%cadr decl))) 'special))
962       (do ((vars (%cdr decl) (%cdr vars)) (decls ()))
963           ((null vars)
964            (cons 'progn (nreverse decls)))
965         (unless (and (car vars)
966                      (neq (%car vars) t)
967                      (symbolp (%car vars)))
968            (return call))
969         (push (list '%proclaim-special (list 'quote (%car vars))) decls))
970       call))
971
972
973(define-compiler-macro some (&whole call &environment env &rest ignore)
974  (declare (ignore ignore))
975  (some-xx-transform call env))
976
977(define-compiler-macro struct-ref (&whole call &environment env struct offset)
978   (if (nx-inhibit-safety-checking env)
979    `(%svref ,struct ,offset)
980    call))
981
982;;; expand find-if and find-if-not
983
984(define-compiler-macro find-if (&whole call &environment env
985                                       test sequence &rest keys)
986  `(find ,test ,sequence
987        :test #'funcall
988        ,@keys))
989
990(define-compiler-macro find-if-not (&whole call &environment env
991                                           test sequence &rest keys)
992  `(find ,test ,sequence
993        :test-not #'funcall
994        ,@keys))
995
996;;; inline some cases, and use a positional function in others
997
998(define-compiler-macro find (&whole call &environment env
999                                    item sequence &rest keys)
1000  (if (constant-keywords-p keys)
1001    (destructuring-bind (&key from-end test test-not (start 0) end key) keys
1002      (if (and (eql start 0)
1003               (null end)
1004               (null from-end)
1005               (not (and test test-not)))
1006        (let ((find-test (or test test-not '#'eql))
1007              (loop-test (if test-not 'unless 'when))
1008              (loop-function (nx-form-sequence-iterator sequence env)))
1009          (if loop-function
1010            (let ((item-var (unless (or (constantp item)
1011                                        (and (equal find-test '#'funcall)
1012                                             (function-form-p item)))
1013                              (gensym)))
1014                  (elt-var (gensym)))
1015              `(let (,@(when item-var `((,item-var ,item))))
1016                 (,loop-function (,elt-var ,sequence)
1017                                 (,loop-test (funcall ,find-test ,(or item-var item)
1018                                                      (funcall ,(or key '#'identity) ,elt-var))
1019                                             (return ,elt-var)))))
1020            (let ((find-function (if test-not 'find-positional-test-not-key 'find-positional-test-key))
1021                  (item-var (gensym))
1022                  (sequence-var (gensym))
1023                  (test-var (gensym))
1024                  (key-var (gensym)))
1025              `(let ((,item-var ,item)
1026                     (,sequence-var ,sequence)
1027                     (,test-var ,(or test test-not))
1028                     (,key-var ,key))
1029                 (declare (dynamic-extent ,item-var ,sequence-var ,test-var ,key-var))
1030                 (,find-function ,item-var ,sequence-var ,test-var ,key-var)))))
1031        call))
1032      call))
1033
1034;;; expand position-if and position-if-not
1035
1036(define-compiler-macro position-if (&whole call &environment env
1037                                           test sequence &rest keys)
1038  `(position ,test ,sequence
1039             :test #'funcall
1040             ,@keys))
1041
1042(define-compiler-macro position-if-not (&whole call &environment env
1043                                               test sequence &rest keys)
1044  `(position ,test ,sequence
1045             :test-not #'funcall
1046             ,@keys))
1047
1048;;; inline some cases, and use positional functions for others
1049
1050(define-compiler-macro position (&whole call &environment env
1051                                        item sequence &rest keys)
1052  (if (constant-keywords-p keys)
1053    (destructuring-bind (&key from-end test test-not (start 0) end key) keys
1054      (if (and (eql start 0)
1055               (null end)
1056               (null from-end)
1057               (not (and test test-not)))
1058        (let ((position-test (or test test-not '#'eql))
1059              (loop-test (if test-not 'unless 'when))
1060              (sequence-value (if (constantp sequence)
1061                                (eval-constant sequence)
1062                                sequence)))
1063          (cond ((nx-form-typep sequence-value 'list env)
1064                 (let ((item-var (unless (or (constantp item)
1065                                             (and (equal position-test '#'funcall)
1066                                                  (function-form-p item)))
1067                                   (gensym)))
1068                       (elt-var (gensym))
1069                       (position-var (gensym)))
1070                   `(let (,@(when item-var `((,item-var ,item)))
1071                          (,position-var 0))
1072                      (dolist (,elt-var ,sequence)
1073                        (,loop-test (funcall ,position-test ,(or item-var item)
1074                                             (funcall ,(or key '#'identity) ,elt-var))
1075                                    (return ,position-var))
1076                        (incf ,position-var)))))
1077                ((nx-form-typep sequence-value 'vector env)
1078                 (let ((item-var (unless (or (constantp item)
1079                                             (and (equal position-test '#'funcall)
1080                                                  (function-form-p item)))
1081                                   (gensym)))
1082                       (sequence-var (gensym))
1083                       (position-var (gensym)))
1084                   `(let (,@(when item-var `((,item-var ,item)))
1085                          (,sequence-var ,sequence))
1086                      ,@(let ((type (nx-form-type sequence env)))
1087                          (unless (eq type t)
1088                            `((declare (type ,type ,sequence-var)))))
1089                      (dotimes (,position-var (length ,sequence-var))
1090                        (,loop-test (funcall ,position-test ,(or item-var item)
1091                                             (funcall ,(or key '#'identity)
1092                                                      (locally (declare (optimize (speed 3) (safety 0)))
1093                                                        (aref ,sequence ,position-var))))
1094                                    (return ,position-var))))))
1095                (t
1096                 (let ((position-function (if test-not
1097                                            'position-positional-test-not-key
1098                                            'position-positional-test-key))
1099                       (item-var (gensym))
1100                       (sequence-var (gensym))
1101                       (test-var (gensym))
1102                       (key-var (gensym)))
1103                   `(let ((,item-var ,item)
1104                          (,sequence-var ,sequence)
1105                          (,test-var ,(or test test-not))
1106                          (,key-var ,key))
1107                      (declare (dynamic-extent ,sequence-var ,test-var ,key-var))
1108                      (,position-function ,item-var ,sequence-var ,test-var ,key-var))))))
1109        call))
1110    call))
1111
1112;;; inline some cases of remove-if and remove-if-not
1113
1114(define-compiler-macro remove-if (&whole call &environment env &rest ignore)
1115  (declare (ignore ignore))
1116  (remove-if-transform call env))
1117
1118(define-compiler-macro remove-if-not (&whole call &environment env &rest ignore)
1119  (declare (ignore ignore))
1120  (remove-if-transform call env))
1121
1122(defun remove-if-transform (call env)
1123  (destructuring-bind (function test sequence &rest keys) call
1124    (if (constant-keywords-p keys)
1125      (destructuring-bind (&key from-end (start 0) end count (key '#'identity)) keys
1126        (if (and (eql start 0)
1127                 (null end)
1128                 (null from-end)
1129                 (null count)
1130                 (nx-form-typep sequence 'list env))
1131          ;; only do the list case, since it's hard to collect vector results
1132          (let ((temp-var (gensym))
1133                (result-var (gensym))
1134                (elt-var (gensym))
1135                (loop-test (ecase function (remove-if 'unless) (remove-if-not 'when))))
1136            `(the list
1137               (let* ((,temp-var (cons nil nil))
1138                      (,result-var ,temp-var))
1139                 (declare (dynamic-extent ,temp-var))
1140                 (dolist (,elt-var ,sequence (%cdr ,result-var))
1141                   (,loop-test (funcall ,test (funcall ,key ,elt-var))
1142                               (setq ,temp-var 
1143                                     (%cdr 
1144                                      (%rplacd ,temp-var (list ,elt-var)))))))))
1145          call))
1146      call)))
1147
1148
1149
1150(define-compiler-macro struct-set (&whole call &environment env struct offset new)
1151  (if (nx-inhibit-safety-checking env)
1152    `(%svset ,struct ,offset ,new)
1153    call))
1154
1155(define-compiler-macro zerop (arg &environment env)
1156  (let* ((z (if (nx-form-typep arg 'float env)
1157              (coerce 0 (nx-form-type arg env))
1158              0)))
1159    `(= ,arg ,z)))
1160
1161
1162(define-compiler-macro = (&whole w n0 &optional (n1 nil n1p) &rest more)
1163  (if (not n1p)
1164    `(require-type ,n0 'number)
1165    (if more
1166      w
1167      `(=-2 ,n0 ,n1))))
1168
1169(define-compiler-macro /= (&whole w n0 &optional (n1 nil n1p) &rest more)
1170  (if (not n1p)
1171    `(require-type ,n0 'number)
1172    (if more
1173      w
1174      `(/=-2 ,n0 ,n1))))
1175
1176(define-compiler-macro + (&whole w  &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
1177  (if more
1178    `(+ (+-2 ,n0 ,n1) ,@more)
1179    (if n1p
1180      `(+-2 ,n0 ,n1)
1181      (if n0p
1182        `(require-type ,n0 'number)
1183        0))))
1184
1185(define-compiler-macro - (&whole w &environment env n0 &optional (n1 nil n1p) &rest more)
1186  (if more
1187    `(- (--2 ,n0 ,n1) ,@more)
1188    (if n1p
1189      `(--2 ,n0 ,n1)
1190      `(%negate ,n0))))
1191
1192(define-compiler-macro * (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
1193  (if more
1194    (let ((type (nx-form-type w env)))
1195      (if (and type (numeric-type-p type)) ; go pairwise if type known, else not
1196        `(*-2 ,n0 (* ,n1 ,@more))
1197        w))
1198    (if n1p
1199      `(*-2 ,n0 ,n1)
1200      (if n0p
1201        `(require-type ,n0 'number)
1202        1))))
1203
1204(define-compiler-macro / (&whole w n0 &optional (n1 nil n1p) &rest more)
1205  (if more
1206    w
1207    (if n1p
1208      `(/-2 ,n0 ,n1)
1209      `(%quo-1 ,n0))))
1210
1211;;; beware of limits - truncate of most-negative-fixnum & -1 ain't a
1212;;; fixnum - too bad
1213(define-compiler-macro truncate (&whole w &environment env n0 &optional (n1 nil n1p))
1214  (let ((*nx-form-type* t))
1215    (if (nx-form-typep n0 'fixnum env)
1216      (if (not n1p)
1217        n0
1218        (if (nx-form-typep n1 'fixnum env)
1219          `(%fixnum-truncate ,n0 ,n1)
1220          w))
1221      w)))
1222
1223(define-compiler-macro floor (&whole w &environment env n0 &optional (n1 nil n1p))
1224  (let ((*nx-form-type* t))
1225    (if (nx-form-typep n0 'fixnum env)
1226      (if (not n1p)
1227        n0
1228        (if (nx-form-typep n1 'fixnum env)
1229          `(%fixnum-floor ,n0 ,n1)
1230          w))
1231      w)))
1232
1233(define-compiler-macro round (&whole w &environment env n0 &optional (n1 nil n1p))
1234  (let ((*nx-form-type* t)) ; it doesn't matter what the result type is declared to be
1235    (if (nx-form-typep n0 'fixnum env)
1236      (if (not n1p)
1237        n0
1238        (if (nx-form-typep n1 'fixnum env)
1239          `(%fixnum-round ,n0 ,n1)
1240          w))
1241      w)))
1242
1243(define-compiler-macro ceiling (&whole w &environment env n0 &optional (n1 nil n1p))
1244  (let ((*nx-form-type* t))
1245    (if (nx-form-typep n0 'fixnum env)
1246      (if (not n1p)
1247        n0
1248        (if (nx-form-typep n1 'fixnum env)
1249          `(%fixnum-ceiling ,n0 ,n1)
1250          w))
1251      w)))
1252
1253(define-compiler-macro oddp (&whole w &environment env n0)
1254  (if (nx-form-typep n0 'fixnum env)
1255    `(logbitp 0 (the fixnum ,n0))
1256    w))
1257
1258(define-compiler-macro evenp (&whole w &environment env n0)
1259  (if (nx-form-typep n0 'fixnum env)
1260    `(not (logbitp 0 (the fixnum ,n0)))
1261    w))
1262 
1263
1264(define-compiler-macro logandc2 (n0 n1)
1265  (let ((n1var (gensym))
1266        (n0var (gensym)))
1267    `(let ((,n0var ,n0)
1268           (,n1var ,n1))
1269       (logandc1 ,n1var ,n0var))))
1270
1271(define-compiler-macro logorc2 (n0 n1)
1272  (let ((n1var (gensym))
1273        (n0var (gensym)))
1274    `(let ((,n0var ,n0)
1275           (,n1var ,n1))
1276       (logorc1 ,n1var ,n0var))))
1277
1278(define-compiler-macro lognand (n0 n1)
1279  `(lognot (logand ,n0 ,n1)))
1280
1281(define-compiler-macro lognor (n0 n1)
1282  `(lognot (logior ,n0 ,n1)))
1283
1284
1285(defun transform-logop (whole identity binop &optional (transform-complement t))
1286  (destructuring-bind (op &optional (n0 nil n0p) (n1 nil n1p) &rest more) whole
1287    (if (and n1p (eql n0 identity))
1288      `(,op ,n1 ,@more)
1289      (if (and transform-complement n1p (eql n0 (lognot identity)))
1290        `(progn
1291           (,op ,n1 ,@more)
1292           ,(lognot identity))
1293        (if more
1294          (if (cdr more)
1295            whole
1296            `(,binop ,n0 (,binop ,n1 ,(car more))))
1297          (if n1p
1298            `(,binop ,n0 ,n1)
1299            (if n0p
1300              `(require-type ,n0 'integer)
1301              identity)))))))
1302         
1303(define-compiler-macro logand (&whole w &rest all)
1304  (declare (ignore all))
1305  (transform-logop w -1 'logand-2))
1306
1307(define-compiler-macro logior (&whole w &rest all)
1308  (declare (ignore all))
1309  (transform-logop w 0 'logior-2))
1310
1311(define-compiler-macro logxor (&whole w &rest all)
1312  (declare (ignore all))
1313  (transform-logop w 0 'logxor-2 nil))
1314
1315(define-compiler-macro lognot (&whole w &environment env n1)
1316  (if (nx-form-typep n1 'fixnum env)
1317    `(%ilognot ,n1)
1318    w))
1319
1320(define-compiler-macro logtest (&whole w &environment env n1 n2)
1321  (if (and (nx-form-typep n1 'fixnum env)
1322           (nx-form-typep n2 'fixnum env))
1323    `(not (eql 0 (logand ,n1 ,n2)))
1324    w))
1325 
1326
1327(defmacro defsynonym (from to)
1328  ;Should maybe check for circularities.
1329  `(progn
1330     (setf (compiler-macro-function ',from) nil)
1331     (let ((pair (assq ',from *nx-synonyms*)))
1332       (if pair (rplacd pair ',to) 
1333           (push (cons ',from ',to) 
1334                 *nx-synonyms*))
1335       ',to)))
1336
1337(defsynonym first car)
1338(defsynonym second cadr)
1339(defsynonym third caddr)
1340(defsynonym fourth cadddr)
1341(defsynonym rest cdr)
1342
1343
1344(defsynonym functionp lfunp)
1345(defsynonym null not)
1346(defsynonym char-int char-code)
1347
1348;;; Improvemets file by Bob Cassels
1349;;; Just what are "Improvemets", anyway ?
1350
1351;;; Optimize some CL sequence functions, mostly by inlining them in
1352;;; simple cases when the type of the sequence is known.  In some
1353;;; cases, dynamic-extent declarations are automatically inserted.
1354;;; For some sequence functions, if the type of the sequence is known
1355;;; at compile time, the function is inlined.  If the type isn't known
1356;;; but the call is "simple", a call to a faster (positional-arg)
1357;;; function is substituted.
1358
1359
1360(defun nx-form-sequence-iterator (sequence-form env)
1361  (cond ((nx-form-typep sequence-form 'vector env) 'dovector)
1362        ((nx-form-typep sequence-form 'list env) 'dolist)))
1363
1364(defun function-form-p (form)
1365   ;; c.f. quoted-form-p
1366   (and (consp form)
1367        (eq (%car form) 'function)
1368        (consp (%cdr form))
1369        (null (%cdr (%cdr form)))))
1370
1371(defun optimize-typep (thing type env)
1372  ;; returns a new form, or nil if it can't optimize
1373  (cond ((symbolp type)
1374         (let ((typep (type-predicate type)))
1375           (cond ((and typep
1376                       (symbolp typep))
1377                  `(,typep ,thing))
1378                 ((%deftype-expander type)
1379                  ;; recurse here, rather than returning the
1380                  ;; partially-expanded form mostly since it doesn't
1381                  ;; seem to further optimize the result otherwise
1382                  (let ((expanded-type (type-expand type)))
1383                    (or (optimize-typep thing expanded-type env)
1384                        ;; at least do the first expansion
1385                        `(typep ,thing ',expanded-type))))
1386                 ((structure-class-p type env)
1387                  `(structure-typep ,thing ',type))
1388                 ((find-class type nil env)
1389                  `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))
1390                 ((info-type-builtin type) ; bootstrap troubles here?
1391                  `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1392                 (t nil))))
1393        ((consp type)
1394         (cond 
1395          ((info-type-builtin type)  ; byte types
1396           `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1397          (t 
1398           (case (%car type)
1399             (satisfies `(funcall ',(cadr type) ,thing))
1400             (eql `(eql ,thing ',(cadr type)))
1401             (member `(not (null (member ,thing ',(%cdr type)))))
1402             (not `(not (typep ,thing ',(cadr type))))
1403             ((or and)
1404              (let ((thing-sym (gensym)))
1405                `(let ((,thing-sym ,thing))
1406                   (,(%car type)
1407                    ,@(mapcar #'(lambda (type-spec)
1408                                  (or (optimize-typep thing-sym type-spec env)
1409                                      `(typep ,thing-sym ',type-spec)))
1410                              (%cdr type))))))
1411             ((signed-byte unsigned-byte integer mod)  ; more byte types
1412              `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
1413             (t nil)))))
1414        (t nil)))
1415
1416(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
1417  (declare (ignore e))
1418  (if (quoted-form-p type)
1419    (or (optimize-typep thing (%cadr type) env)
1420        call)
1421    call))
1422
1423(define-compiler-macro true (&rest args)
1424  `(progn
1425    ,@args
1426    t))
1427
1428
1429(define-compiler-macro false (&rest args)
1430  `(progn
1431    ,@args
1432    nil))
1433
1434(define-compiler-macro find-class (&whole call type &optional (errorp t) env)
1435  (if (and (quoted-form-p type)(not *dont-find-class-optimize*)(not env))
1436      `(class-cell-find-class (load-time-value (find-class-cell ,type t)) ,errorp)
1437    call))
1438
1439
1440(define-compiler-macro gcd (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
1441  (if rest
1442    call
1443    (if n1-p
1444      `(gcd-2 ,n0 ,n1)
1445      (if n0-p
1446        `(%integer-abs ,n0)
1447        0))))
1448
1449(define-compiler-macro lcm (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
1450  (if rest
1451    call
1452    (if n1-p
1453      `(lcm-2 ,n0 ,n1)
1454      (if n0-p
1455        `(%integer-abs ,n0)
1456        1))))
1457
1458(define-compiler-macro max (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
1459  (if rest
1460    call
1461    (if n1-p
1462      (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
1463        `(imax-2 ,n0 ,n1)
1464        `(max-2 ,n0 ,n1))
1465      `(require-type ,n0 'real))))
1466
1467(define-compiler-macro max-2 (n0 n1)
1468  (let* ((g0 (gensym))
1469         (g1 (gensym)))
1470   `(let* ((,g0 ,n0)
1471           (,g1 ,n1))
1472      (if (> ,g0 ,g1) ,g0 ,g1))))
1473
1474(define-compiler-macro imax-2 (n0 n1)
1475  (let* ((g0 (gensym))
1476         (g1 (gensym)))
1477   `(let* ((,g0 ,n0)
1478           (,g1 ,n1))
1479      (if (%i> ,g0 ,g1) ,g0 ,g1))))
1480
1481
1482
1483
1484(define-compiler-macro min (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
1485  (if rest
1486    call
1487    (if n1-p
1488      (if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
1489        `(imin-2 ,n0 ,n1)
1490        `(min-2 ,n0 ,n1))
1491      `(require-type ,n0 'real))))
1492
1493(define-compiler-macro min-2 (n0 n1)
1494  (let* ((g0 (gensym))
1495         (g1 (gensym)))
1496   `(let* ((,g0 ,n0)
1497           (,g1 ,n1))
1498      (if (< ,g0 ,g1) ,g0 ,g1))))
1499
1500(define-compiler-macro imin-2 (n0 n1)
1501  (let* ((g0 (gensym))
1502         (g1 (gensym)))
1503   `(let* ((,g0 ,n0)
1504           (,g1 ,n1))
1505      (if (%i< ,g0 ,g1) ,g0 ,g1))))
1506
1507
1508(defun eq-test-p (test)
1509  (or (equal test ''eq) (equal test '#'eq)))
1510
1511(defun eql-test-p (test)
1512  (or (equal test ''eql) (equal test '#'eql)))
1513
1514(define-compiler-macro adjoin (&whole whole elt list &rest keys)
1515  (if (constant-keywords-p keys)
1516    (destructuring-bind (&key (test ''eql) test-not key) keys
1517      (or (and (null test-not)
1518               (null key)
1519               (cond ((eq-test-p test)
1520                      `(adjoin-eq ,elt ,list))
1521                     ((eql-test-p test)
1522                      `(adjoin-eql ,elt ,list))
1523                     (t nil)))
1524          whole))
1525    whole))
1526
1527(define-compiler-macro union (&whole whole list1 list2 &rest keys)
1528  (if (constant-keywords-p keys)
1529    (destructuring-bind (&key (test ''eql) test-not key) keys
1530      (or (and (null test-not)
1531               (null key)
1532               (cond ((eq-test-p test)
1533                      `(union-eq ,list1 ,list2))
1534                     ((eql-test-p test)
1535                      `(union-eql ,list1 ,list2))
1536                     (t nil)))
1537          whole))
1538    whole))
1539
1540(define-compiler-macro slot-value (&whole whole &environment env
1541                                          instance slot-name-form)
1542  (declare (ignore env))
1543  (let* ((name (and (quoted-form-p slot-name-form)
1544                    (typep (cadr slot-name-form) 'symbol)
1545                    (cadr slot-name-form))))
1546    (if name
1547      `(slot-id-value ,instance (load-time-value (ensure-slot-id ',name)))
1548      whole)))
1549
1550
1551(define-compiler-macro set-slot-value (&whole whole &environment env
1552                                          instance slot-name-form value-form)
1553  (declare (ignore env))
1554  (let* ((name (and (quoted-form-p slot-name-form)
1555                    (typep (cadr slot-name-form) 'symbol)
1556                    (cadr slot-name-form))))
1557    (if name
1558      `(set-slot-id-value
1559        ,instance
1560        (load-time-value (ensure-slot-id ',name))
1561        ,value-form)
1562      whole)))
1563
1564
1565
1566                       
1567(defsynonym %get-unsigned-byte %get-byte)
1568(defsynonym %get-unsigned-word %get-word)
1569(defsynonym %get-signed-long %get-long)
1570
1571
1572
1573
1574(define-compiler-macro arrayp (arg)
1575  `(>= (the fixnum (typecode ,arg))
1576    ,(nx-lookup-target-uvector-subtag :array-header)))
1577
1578(define-compiler-macro vectorp (arg)
1579  `(>= (the fixnum (typecode ,arg))
1580    ,(nx-lookup-target-uvector-subtag :vector-header)))
1581
1582
1583
1584(define-compiler-macro fixnump (arg)
1585  (let* ((fixnum-tag
1586          (arch::target-fixnum-tag (backend-target-arch *target-backend*))))
1587    `(eql (lisptag ,arg) ,fixnum-tag)))
1588
1589
1590
1591(define-compiler-macro double-float-p (n)
1592  (let* ((tag (arch::target-double-float-tag (backend-target-arch *target-backend*))))
1593    `(eql (typecode ,n) ,tag)))
1594
1595
1596(define-compiler-macro short-float-p (n)
1597  (let* ((arch (backend-target-arch *target-backend*))
1598         (tag (arch::target-single-float-tag arch))
1599         (op (if (arch::target-single-float-tag-is-subtag arch)
1600               'typecode
1601               'fulltag)))
1602    `(eql (,op ,n) ,tag)))
1603
1604
1605(define-compiler-macro floatp (n)
1606  (let* ((typecode (make-symbol "TYPECODE"))
1607         (arch (backend-target-arch *target-backend*))
1608         (single (arch::target-single-float-tag arch))
1609         (double (arch::target-double-float-tag arch)))
1610    `(let* ((,typecode (typecode ,n)))
1611       (declare (fixnum ,typecode))
1612       (or (= ,typecode ,single)
1613           (= ,typecode ,double)))))
1614
1615(define-compiler-macro functionp (n)
1616  (let* ((arch (backend-target-arch *target-backend*))
1617         (tag (arch::target-function-tag arch))
1618         (op (if (arch::target-function-tag-is-subtag arch)
1619               'typecode
1620               'fulltag)))
1621    `(eql (,op  ,n) ,tag)))
1622
1623(define-compiler-macro symbolp (s)
1624  (let* ((arch (backend-target-arch *target-backend*))
1625         (symtag (arch::target-symbol-tag arch))
1626         (op (if (arch::target-symbol-tag-is-subtag arch)
1627               'typecode
1628               'fulltag))
1629         (niltag (arch::target-null-tag arch)))
1630    (if (eql niltag symtag)
1631      `(eql (,op ,s) ,symtag)
1632      (let* ((sym (gensym)))
1633        `(let* ((,sym ,s))
1634          (if ,sym (eql (,op ,sym) ,symtag) t))))))
1635
1636;;; If NIL isn't tagged as a symbol, assume that LISPTAG only looks
1637;;; at bits that NIL shares with a cons.
1638(define-compiler-macro listp (n)
1639  (let* ((arch (backend-target-arch *target-backend*))
1640         (cons-tag (arch::target-cons-tag arch))
1641         (nil-tag  (arch::target-null-tag arch))
1642         (symbol-tag (arch::target-symbol-tag arch)))
1643    (if (= nil-tag symbol-tag)
1644      (let* ((nvar (gensym)))
1645        `(let* ((,nvar ,n))
1646          (if ,nvar (consp ,nvar) t)))
1647      `(eql (lisptag ,n) ,cons-tag))))
1648
1649(define-compiler-macro consp (n)
1650  (let* ((cons-tag (arch::target-cons-tag (backend-target-arch *target-backend*))))
1651  `(eql (fulltag ,n) ,cons-tag)))
1652
1653(define-compiler-macro bignump (n)
1654  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :bignum)))
1655
1656(define-compiler-macro ratiop (n)
1657  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :ratio)))
1658
1659(define-compiler-macro complexp (n)
1660  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :complex)))
1661
1662(define-compiler-macro macptrp (n)
1663  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :macptr)))
1664
1665(define-compiler-macro basic-stream-p (n)
1666  `(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :basic-stream)))
1667
1668(define-compiler-macro aref (&whole call a &rest subscripts &environment env)
1669  (let* ((ctype (if (nx-form-typep a 'array env)
1670                  (specifier-type (nx-form-type a env))))
1671         (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype))))
1672         (useful (unless (or (eq type *) (eq type t))
1673                   type))) 
1674    (if (= 2 (length subscripts))
1675      (setq call `(%aref2 ,a ,@subscripts))
1676      (if (= 3 (length subscripts))
1677        (setq call `(%aref3 ,a ,@subscripts))))
1678    (if useful
1679      `(the ,useful ,call)
1680      call)))
1681
1682
1683(define-compiler-macro aset (&whole call a &rest subs&val)
1684  (if (= 3 (length subs&val))
1685    `(%aset2 ,a ,@subs&val)
1686    (if (= 4 (length subs&val))
1687      `(%aset3 ,a ,@subs&val)
1688      call)))
1689
1690
1691(define-compiler-macro make-sequence (&whole call &environment env typespec len &rest keys &key initial-element)
1692  (declare (ignore typespec len keys initial-element))
1693  call)
1694
1695(define-compiler-macro make-string (&whole call size &rest keys)
1696  (if (constant-keywords-p keys)
1697    (destructuring-bind (&key (element-type () element-type-p)
1698                              (initial-element () initial-element-p))
1699                        keys
1700      (if (and element-type-p
1701               (quoted-form-p element-type))
1702        (let* ((element-type (cadr element-type)))
1703          (if (subtypep element-type 'base-char)
1704            `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
1705            call))
1706        (if (not element-type-p)
1707          `(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
1708          call)))
1709    call))
1710
1711(define-compiler-macro make-string-output-stream (&whole whole &rest keys)
1712  (if (null keys)
1713    '(make-simple-string-output-stream)
1714    whole))
1715
1716
1717(define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others)
1718  (if (and sub0 (null others))
1719    `(aref (the simple-bit-vector ,v) ,sub0)
1720    call))
1721
1722(define-compiler-macro %sbitset (&environment env &whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)
1723  (if (and newval-p (not newval-was-really-sub1) )
1724    `(setf (aref (the simple-bit-vector ,v) ,sub0) ,newval)
1725    call))
1726
1727(define-compiler-macro simple-base-string-p (thing)
1728  `(= (the fixnum (typecode ,thing)) ,(nx-lookup-target-uvector-subtag :simple-string)))
1729
1730(define-compiler-macro simple-string-p (thing)
1731  `(simple-base-string-p ,thing))
1732
1733
1734(defsetf %misc-ref %misc-set)
1735
1736
1737(define-compiler-macro lockp (lock)
1738  (let* ((tag (nx-lookup-target-uvector-subtag :simple-string)))
1739    `(eq ,tag (typecode ,lock))))
1740
1741
1742(define-compiler-macro integerp (thing) 
1743  (let* ((typecode (gensym))
1744         (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*)))
1745         (bignum-tag (nx-lookup-target-uvector-subtag :bignum)))
1746    `(let* ((,typecode (typecode ,thing)))
1747      (declare (fixnum ,typecode))
1748      (or (= ,typecode ,fixnum-tag)
1749       (= ,typecode ,bignum-tag)))))
1750       
1751(define-compiler-macro %composite-pointer-ref (size pointer offset)
1752  (if (constantp size)
1753    `(%inc-ptr ,pointer ,offset)
1754    `(progn
1755      ,size
1756      (%inc-ptr ,pointer ,offset))))
1757
1758
1759(define-compiler-macro char= (&whole call ch &optional (other nil other-p) &rest others)
1760  (if (null others)
1761    (if other-p
1762      `(eq (char-code ,ch) (char-code ,other))
1763      `(progn (char-code ,ch) t))
1764    (if (null (cdr others))
1765      (let* ((third (car others))
1766             (code (gensym)))
1767        `(let* ((,code (char-code ,ch)))
1768          (and (eq ,code (setq ,code (char-code ,other)))
1769           (eq ,code (char-code ,third)))))
1770      call)))
1771
1772(define-compiler-macro char-equal (&whole call ch &optional (other nil other-p) &rest others)
1773  (if (null others)
1774    (if other-p
1775      `(eq (%char-code (char-upcase ,ch)) (%char-code (char-upcase ,other)))
1776      `(progn (char-code ,ch) t))
1777    (if (null (cdr others))
1778      (let* ((third (car others))
1779             (code (gensym)))
1780        `(let* ((,code (%char-code (char-upcase ,ch))))
1781          (and (eq ,code (setq ,code (%char-code (char-upcase ,other))))
1782           (eq ,code (%char-code (char-upcase ,third))))))
1783      call)))
1784
1785(define-compiler-macro char/= (&whole call ch &optional (other nil other-p) &rest others)
1786  (if (null others)
1787    (if other-p
1788      `(not (eq (char-code ,ch) (char-code ,other)))
1789      `(progn (char-code ,ch) t))
1790    call))
1791
1792
1793(define-compiler-macro char< (&whole call ch &optional (other nil other-p) &rest others)
1794  (if (null others)
1795    (if other-p
1796      `(< (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
1797      `(progn (char-code ,ch) t))
1798    (if (null (cdr others))
1799      (let* ((third (car others))
1800             (code (gensym)))
1801        `(let* ((,code (char-code ,ch)))
1802          (declare (fixnum ,code))
1803          (and (< ,code (setq ,code (char-code ,other)))
1804           (< ,code (the fixnum (char-code ,third))))))
1805      call)))
1806
1807(define-compiler-macro char<= (&whole call ch &optional (other nil other-p) &rest others)
1808  (if (null others)
1809    (if other-p
1810      `(<= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
1811      `(progn (char-code ,ch) t))
1812    (if (null (cdr others))
1813      (let* ((third (car others))
1814             (code (gensym)))
1815        `(let* ((,code (char-code ,ch)))
1816          (declare (fixnum ,code))
1817          (and (<= ,code (setq ,code (char-code ,other)))
1818           (<= ,code (the fixnum (char-code ,third))))))
1819      call)))
1820
1821(define-compiler-macro char> (&whole call ch &optional (other nil other-p) &rest others)
1822  (if (null others)
1823    (if other-p
1824      `(> (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
1825      `(progn (char-code ,ch) t))
1826    (if (null (cdr others))
1827      (let* ((third (car others))
1828             (code (gensym)))
1829        `(let* ((,code (char-code ,ch)))
1830          (declare (fixnum ,code))
1831          (and (> ,code (setq ,code (char-code ,other)))
1832           (> ,code (the fixnum (char-code ,third))))))
1833      call)))
1834
1835(define-compiler-macro char>= (&whole call ch &optional (other nil other-p) &rest others)
1836  (if (null others)
1837    (if other-p
1838      `(>= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
1839      `(progn (char-code ,ch) t))
1840    (if (null (cdr others))
1841      (let* ((third (car others))
1842             (code (gensym)))
1843        `(let* ((,code (char-code ,ch)))
1844          (declare (fixnum ,code))
1845          (and (>= ,code (setq ,code (char-code ,other)))
1846           (>= ,code (the fixnum (char-code ,third))))))
1847      call)))
1848
1849(define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env)
1850 
1851  (cond ((and (typep other 'single-float)
1852              (nx-form-typep number 'double-float env))
1853         `(the single-float (%double-to-single ,number)))
1854        ((and (typep other 'double-float)
1855              (nx-form-typep number 'single-float env))
1856         `(the double-float (%single-to-double ,number)))
1857        ((and other-p (typep other 'single-float))
1858         `(the single-float (%short-float ,number)))
1859        ((typep other 'double-float)
1860         `(the double-float (%double-float ,number)))
1861        ((null other-p)
1862         (let* ((temp (gensym)))
1863           `(let* ((,temp ,number))
1864             (if (typep ,temp 'double-float)
1865               ,temp
1866               (the single-float (%short-float ,temp))))))
1867        (t call)))
1868
1869(define-compiler-macro coerce (&whole call thing type)
1870  (if (quoted-form-p type)
1871    (setq type (cadr type)))
1872  (if (ignore-errors (subtypep type 'single-float))
1873    `(float ,thing 0.0f0)
1874    (if (ignore-errors (subtypep type 'double-float))
1875      `(float ,thing 0.0d0)
1876      call)))
1877
1878(define-compiler-macro equal (&whole call x y &environment env)
1879  (if (or (equal-iff-eql-p x env)
1880          (equal-iff-eql-p y env))
1881    `(eql ,x ,y)
1882    call))
1883
1884(provide "OPTIMIZERS")
1885
Note: See TracBrowser for help on using the repository browser.