Context Navigation

source: branches/working-0711/ccl/compiler/optimizers.lisp @ 10348

Visit:

Last change on this file since 10348 was 10348, checked in by gb, 12 years ago
Missing comma in compiler-macro for 3-arg case of CHAR> .
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 92.0 KB

Rev	Line
[6]	1	;;;-- Mode: Lisp; Package: CCL --
	2	;;;
	3	;;; Copyright (C) 1994-2001 Digitool, Inc
[9389]	4	;;; This file is part of OpenMCL.
[6]	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
[9389]	10	;;; conflict, the preamble takes precedence.
[6]	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
[2332]	16
[6]	17	; Optimizers.lisp - compiler optimizers
	18
[2332]	19	(in-package "CCL")
	20
[6]	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))
[9389]	60	(%symbol-bits name (logior
[6]	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
[1989]	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.
[1140]	70	(can-constant-fold '(specfier-type %ilsl %ilsr 1- 1+ eql eq
[6]	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)))
[9389]	120	(return
[6]	121	(fixnumify (nreverse targs) op))))
	122	call))
	123
[10008]	124	;;; True if arg is an alternating list of keywords and args, only
	125	;;; recognizes keywords in keyword package. Historical note: this
	126	;;; used to try to ensure that the keyword appeared at most once. Why
	127	;;; ? (Even before destructuring, pl-search/getf would have dtrt.)
	128	;;; Side effects: it's not the right thing to simply pick the value
	129	;;; associated with the first occurrence of a keyword if the value
	130	;;; associated with subsequent occurrence could have a side-effect.
	131	;;; (We -can- ignore a duplicate key if the associated value is
	132	;;; side-effect free.)
[6]	133	(defun constant-keywords-p (keys)
	134	(when (plistp keys)
[10008]	135	(do* ((seen ())
	136	(keys keys (cddr keys)))
	137	((null keys) t)
	138	(let* ((key (car keys)))
	139	(if (or (not (keywordp key))
	140	(and (memq key seen)
	141	(not (constantp (cadr keys)))))
	142	(return))
	143	(push key seen)))))
[6]	144
[10008]	145
[7624]	146	(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly)
	147	(if (null keys)
	148	`(,default ,item ,list)
	149	(if (constant-keywords-p keys)
[6]	150	(destructuring-bind (&key (test nil test-p)
	151	(test-not nil test-not-p)
	152	(key nil key-p))
	153	keys
[7624]	154	(declare (ignore test-not))
[9389]	155	(if (and test-p
[7624]	156	(not test-not-p)
	157	(or (not key-p)
	158	(and (consp key)
	159	(consp (%cdr key))
	160	(null (%cddr key))
	161	(or (eq (%car key) 'function)
	162	(eq (%car key) 'quote))
	163	(eq (%cadr key) 'identity)))
[9389]	164	(consp test)
[6]	165	(consp (%cdr test))
	166	(null (%cddr test))
	167	(or (eq (%car test) 'function)
	168	(eq (%car test) 'quote)))
[7624]	169	(let* ((testname (%cadr test))
	170	(reduced (cdr (assoc testname alist))))
	171	(if reduced
	172	`(,reduced ,item ,list)
	173	`(,testonly ,item ,list ,test))))))))
[6]	174
[7624]	175
[6]	176	(defun eql-iff-eq-p (thing env)
[3660]	177	(if (quoted-form-p thing)
	178	(setq thing (%cadr thing))
	179	(if (not (self-evaluating-p thing))
[6]	180	(return-from eql-iff-eq-p
[7624]	181	(or (nx-form-typep thing 'symbol env)
	182	(nx-form-typep thing 'character env)
	183	(nx-form-typep thing
	184	'(or fixnum
	185	#+64-bit-target single-float
	186	symbol character
	187	(and (not number) (not macptr))) env)))))
[3660]	188	(or (fixnump thing) #+64-bit-target (typep thing 'single-float)
[7624]	189	(symbolp thing) (characterp thing)
[3660]	190	(and (not (numberp thing)) (not (macptrp thing)))))
[6]	191
[7624]	192	(defun equal-iff-eql-p (thing env)
	193	(if (quoted-form-p thing)
	194	(setq thing (%cadr thing))
	195	(if (not (self-evaluating-p thing))
	196	(return-from equal-iff-eql-p
	197	(nx-form-typep thing
	198	'(and (not cons) (not string) (not bit-vector) (not pathname)) env))))
	199	(not (typep thing '(or cons string bit-vector pathname))))
	200
	201
[6]	202	(defun fold-constant-subforms (call env)
	203	(let* ((constants nil)
	204	(forms nil))
	205	(declare (list constants forms))
	206	(dolist (form (cdr call))
	207	(setq form (nx-transform form env))
	208	(if (numberp form)
	209	(setq constants (%temp-cons form constants))
	210	(setq forms (%temp-cons form forms))))
	211	(if constants
	212	(let* ((op (car call))
	213	(constant (if (cdr constants) (handler-case (apply op constants)
[9389]	214	(error (c) (declare (ignore c))
[6]	215	(return-from fold-constant-subforms (values call t))))
	216	(car constants))))
	217	(values (if forms (cons op (cons constant (reverse forms))) constant) t))
	218	(values call nil))))
	219
	220	;;; inline some, etc. in some cases
	221	;;; in all cases, add dynamic-extent declarations
	222	(defun some-xx-transform (call env)
	223	(destructuring-bind (func predicate sequence &rest args) call
	224	(multiple-value-bind (func-constant end-value loop-test)
	225	(case func
	226	(some (values $some nil 'when))
	227	(notany (values $notany t 'when))
	228	(every (values $every t 'unless))
	229	(notevery (values $notevery nil 'unless)))
	230	(if args
	231	(let ((func-sym (gensym))
	232	(seq-sym (gensym))
	233	(list-sym (gensym)))
	234	`(let ((,func-sym ,predicate)
	235	(,seq-sym ,sequence)
	236	(,list-sym (list ,@args)))
	237	(declare (dynamic-extent ,func-sym ,list-sym ,seq-sym))
	238	(some-xx-multi ,func-constant ,end-value ,func-sym ,seq-sym ,list-sym)))
	239	(let ((loop-function (nx-form-sequence-iterator sequence env)))
	240	;; inline if we know the type of the sequence and if
	241	;; the predicate is a lambda expression
	242	;; otherwise, it blows up the code for not much gain
	243	(if (and loop-function
	244	(function-form-p predicate)
	245	(lambda-expression-p (second predicate)))
	246	(let ((elt-var (gensym)))
	247	(case func
	248	(some
	249	`(,loop-function (,elt-var ,sequence ,end-value)
	250	(let ((result (funcall ,predicate ,elt-var)))
	251	(when result (return result)))))
	252	((every notevery notany)
	253	`(,loop-function (,elt-var ,sequence ,end-value)
	254	(,loop-test (funcall ,predicate ,elt-var)
	255	(return ,(not end-value)))))))
	256	(let ((func-sym (gensym))
	257	(seq-sym (gensym)))
	258	`(let ((,func-sym ,predicate)
	259	(,seq-sym ,sequence))
	260	(declare (dynamic-extent ,func-sym ,seq-sym))
	261	(some-xx-one ,func-constant ,end-value ,func-sym ,seq-sym)))))))))
	262
	263
	264	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
[1989]	265	;;;
	266	;;; The new (roughly alphabetical) order.
[9389]	267	;;;
[6]	268	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	269
[1989]	270	;;; Compiler macros on functions can assume that their arguments have
	271	;;; already been transformed.
[6]	272
	273
	274	(defun transform-real-n-ary-comparision (whole binary-name)
	275	(destructuring-bind (n0 &optional (n1 0 n1-p) &rest more) (cdr whole)
	276	(if more
[2248]	277	(if (cdr more)
	278	whole
	279	(let* ((n2 (car more))
	280	(n (gensym)))
	281	`(let* ((,n ,n0))
	282	(if (,binary-name ,n (setq ,n ,n1))
	283	(,binary-name ,n ,n2)))))
[6]	284	(if (not n1-p)
	285	`(require-type ,n0 'real)
	286	`(,binary-name ,n0 ,n1)))))
	287
	288
	289
	290	(define-compiler-macro < (&whole whole &rest ignore)
	291	(declare (ignore ignore))
	292	(transform-real-n-ary-comparision whole '<-2))
	293
	294	(define-compiler-macro > (&whole whole &rest ignore)
	295	(declare (ignore ignore))
	296	(transform-real-n-ary-comparision whole '>-2))
	297
	298	(define-compiler-macro <= (&whole whole &rest ignore)
	299	(declare (ignore ignore))
	300	(transform-real-n-ary-comparision whole '<=-2))
	301
	302	(define-compiler-macro >= (&whole whole &rest ignore)
	303	(declare (ignore ignore))
	304	(transform-real-n-ary-comparision whole '>=-2))
	305
	306
	307	(define-compiler-macro 1- (x)
	308	`(- ,x 1))
	309
	310	(define-compiler-macro 1+ (x)
	311	`(+ ,x 1))
	312
[9389]	313	(define-compiler-macro append (&whole call
	314	&optional arg0
	315	&rest
	316	(&whole tail
	317	&optional (junk nil arg1-p)
[6]	318	&rest more))
	319	;(append (list x y z) A) -> (list* x y z A)
	320	(if (and arg1-p
	321	(null more)
	322	(consp arg0)
	323	(eq (%car arg0) 'list))
	324	(cons 'list* (append (%cdr arg0) tail))
	325	(if (and arg1-p (null more))
	326	`(append-2 ,arg0 ,junk)
	327	call)))
	328
	329	(define-compiler-macro apply (&whole call &environment env fn arg0 &rest args)
[7841]	330	;; Special-case (apply #'make-instance 'name ...)
	331	;; Might be good to make this a little more general, e.g., there
	332	;; may be other things that can be strength-reduced even if we can't
	333	;; get rid of the APPLY.
	334	(if (and (consp fn)
	335	(or (eq (car fn) 'quote)
	336	(eq (car fn) 'function))
	337	(consp (cdr fn))
	338	(null (cddr fn))
	339	(eq (cadr fn) 'make-instance)
	340	(consp arg0)
[7843]	341	(eq (car arg0) 'quote)
[7841]	342	(consp (cdr arg0))
	343	(symbolp (cadr arg0)))
	344	(let* ((name (cadr arg0))
	345	(class-cell (gensym)))
	346	`(let* ((,class-cell (load-time-value (find-class-cell ',name t))))
	347	(apply (class-cell-instantiate ,class-cell) ,class-cell ,@args)))
	348	(let ((original-fn fn))
[9389]	349	(if (and arg0
[7841]	350	(null args)
	351	(consp fn)
	352	(eq (%car fn) 'function)
	353	(null (cdr (%cdr fn)))
	354	(consp (setq fn (%cadr fn)))
	355	(eq (%car fn) 'lambda))
	356	(destructuring-bind (lambda-list &body body) (%cdr fn)
	357	`(destructuring-bind ,lambda-list ,arg0 ,@body))
	358	(let ((last (%car (last (push arg0 args)))))
	359	(if (and (consp last) (memq (%car last) '(cons list* list)))
	360	(cons (if (eq (%car last) 'list) 'funcall 'apply)
	361	(cons
	362	original-fn
	363	(nreconc (cdr (reverse args)) (%cdr last))))
	364	call))))))
[6]	365
	366
	367
[7624]	368	(define-compiler-macro assoc (&whole call item list &rest keys)
	369	(or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql . asseql) (equal . assequal)) 'assoc-test)
[6]	370	call))
	371
[7624]	372	(define-compiler-macro assequal (&whole call &environment env item list)
	373	(if (or (equal-iff-eql-p item env)
	374	(and (quoted-form-p list)
	375	(proper-list-p (%cadr list))
	376	(every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list))))
	377	`(asseql ,item ,list)
	378	call))
[9389]	379
[7624]	380	(define-compiler-macro asseql (&whole call &environment env item list)
	381	(if (or (eql-iff-eq-p item env)
	382	(and (quoted-form-p list)
	383	(proper-list-p (%cadr list))
	384	(every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list))))
	385	`(assq ,item ,list)
	386	call))
[2280]	387
[7624]	388	(define-compiler-macro assq (item list)
	389	(let* ((itemx (gensym))
	390	(listx (gensym))
	391	(pair (gensym)))
	392	`(let* ((,itemx ,item)
	393	(,listx ,list))
	394	(dolist (,pair ,listx)
	395	(when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair))))))
	396
[2280]	397	(define-compiler-macro caar (form)
	398	`(car (car ,form)))
	399
	400	(define-compiler-macro cadr (form)
	401	`(car (cdr ,form)))
	402
	403	(define-compiler-macro cdar (form)
	404	`(cdr (car ,form)))
	405
	406	(define-compiler-macro cddr (form)
	407	`(cdr (cdr ,form)))
	408
[6]	409	(define-compiler-macro caaar (form)
	410	`(car (caar ,form)))
	411
	412	(define-compiler-macro caadr (form)
	413	`(car (cadr ,form)))
	414
	415	(define-compiler-macro cadar (form)
	416	`(car (cdar ,form)))
	417
	418	(define-compiler-macro caddr (form)
	419	`(car (cddr ,form)))
	420
	421	(define-compiler-macro cdaar (form)
	422	`(cdr (caar ,form)))
	423
	424	(define-compiler-macro cdadr (form)
	425	`(cdr (cadr ,form)))
	426
	427	(define-compiler-macro cddar (form)
	428	`(cdr (cdar ,form)))
	429
	430	(define-compiler-macro cdddr (form)
	431	`(cdr (cddr ,form)))
	432
[2280]	433	(define-compiler-macro caaaar (form)
	434	`(car (caaar ,form)))
[9389]	435
[2280]	436	(define-compiler-macro caaadr (form)
	437	`(car (caadr ,form)))
[6]	438
[2280]	439	(define-compiler-macro caadar (form)
	440	`(car (cadar ,form)))
[6]	441
[2280]	442	(define-compiler-macro caaddr (form)
	443	`(car (caddr ,form)))
[6]	444
[2280]	445	(define-compiler-macro cadaar (form)
	446	`(car (cdaar ,form)))
	447
	448	(define-compiler-macro cadadr (form)
	449	`(car (cdadr ,form)))
	450
	451	(define-compiler-macro caddar (form)
	452	`(car (cddar ,form)))
	453
	454	(define-compiler-macro cadddr (form)
	455	`(car (cdddr ,form)))
	456
	457	(define-compiler-macro cdaaar (form)
	458	`(cdr (caaar ,form)))
[9389]	459
[2280]	460	(define-compiler-macro cdaadr (form)
	461	`(cdr (caadr ,form)))
	462
	463	(define-compiler-macro cdadar (form)
	464	`(cdr (cadar ,form)))
	465
	466	(define-compiler-macro cdaddr (form)
	467	`(cdr (caddr ,form)))
	468
	469	(define-compiler-macro cddaar (form)
	470	`(cdr (cdaar ,form)))
	471
	472	(define-compiler-macro cddadr (form)
	473	`(cdr (cdadr ,form)))
	474
	475	(define-compiler-macro cdddar (form)
	476	`(cdr (cddar ,form)))
	477
	478	(define-compiler-macro cddddr (form)
	479	`(cdr (cdddr ,form)))
	480
	481
	482
	483
[6]	484	(define-compiler-macro cons (&whole call &environment env x y &aux dcall ddcall)
	485	(if (consp (setq dcall y))
	486	(cond
	487	((or (eq (%car dcall) 'list) (eq (%car dcall) 'list*))
	488	;(CONS A (LIST[] . args)) -> (LIST[] A . args)
	489	(list* (%car dcall) x (%cdr dcall)))
	490	((or (neq (%car dcall) 'cons) (null (cddr dcall)) (cdddr dcall))
	491	call)
	492	((null (setq ddcall (%caddr dcall)))
	493	;(CONS A (CONS B NIL)) -> (LIST A B)
	494	`(list ,x ,(%cadr dcall)))
	495	((and (consp ddcall)
	496	(eq (%car ddcall) 'cons)
	497	(eq (list-length ddcall) 3))
	498	;(CONS A (CONS B (CONS C D))) -> (LIST* A B C D)
	499	(list* 'list* x (%cadr dcall) (%cdr ddcall)))
	500	(t call))
	501	call))
	502
[9389]	503	(define-compiler-macro dotimes (&whole call (i n &optional result)
[6]	504	&body body
	505	&environment env)
	506	(multiple-value-bind (body decls) (parse-body body env)
	507	(if (nx-form-typep (setq n (nx-transform n env)) 'fixnum env)
	508	(let* ((limit (gensym))
	509	(upper (if (constantp n) n most-positive-fixnum))
	510	(top (gensym))
	511	(test (gensym)))
	512	`(let* ((,limit ,n) (,i 0))
	513	,@decls
	514	(declare (fixnum ,limit)
	515	(type (integer 0 ,(if (<= upper 0) 0 `(,upper))) ,i)
	516	(unsettable ,i))
	517	(block nil
	518	(tagbody
	519	(go ,test)
	520	,top
	521	,@body
	522	(locally
	523	(declare (settable ,i))
	524	(setq ,i (1+ ,i)))
	525	,test
	526	(when (< ,i ,limit) (go ,top)))
	527	,result)))
	528	call)))
	529
	530	(define-compiler-macro dpb (&whole call &environment env value byte integer)
[305]	531	(cond ((and (integerp byte) (> byte 0))
[6]	532	(if (integerp value)
	533	`(logior ,(dpb value byte 0) (logand ,(lognot byte) ,integer))
	534	`(deposit-field (ash ,value ,(byte-position byte)) ,byte ,integer)))
	535	((and (consp byte)
	536	(eq (%car byte) 'byte)
	537	(eq (list-length (%cdr byte)) 2))
	538	`(deposit-byte ,value ,(%cadr byte) ,(%caddr byte) ,integer))
	539	(t call)))
	540
	541	(define-compiler-macro eql (&whole call &environment env v1 v2)
	542	(if (or (eql-iff-eq-p v1 env) (eql-iff-eq-p v2 env))
	543	`(eq ,v1 ,v2)
	544	call))
	545
	546	(define-compiler-macro every (&whole call &environment env &rest ignore)
	547	(declare (ignore ignore))
	548	(some-xx-transform call env))
	549
	550
	551	(define-compiler-macro identity (form) form)
	552
	553	(define-compiler-macro if (&whole call test true &optional false &environment env)
	554	(multiple-value-bind (test test-win) (nx-transform test env)
[8554]	555	(if (or (quoted-form-p test) (self-evaluating-p test))
[9389]	556	(if (eval test)
[8554]	557	true
	558	false)
	559	(if test-win
	560	`(if ,test ,@(cddr call))
	561	call))))
[6]	562
	563	(define-compiler-macro %ilsr (&whole call &environment env shift value)
	564	(if (eql shift 0)
	565	value
	566	(if (eql value 0)
	567	`(progn ,shift 0)
	568	call)))
	569
[9389]	570	(defun string-designator-p (object)
	571	(typecase object
	572	(character t)
	573	(symbol t)
	574	(string t)))
[6]	575
	576	(define-compiler-macro ldb (&whole call &environment env byte integer)
[305]	577	(cond ((and (integerp byte) (> byte 0))
[6]	578	(let ((size (byte-size byte))
	579	(position (byte-position byte)))
	580	(cond ((nx-form-typep integer 'fixnum env)
	581	`(logand ,(byte-mask size)
[5263]	582	(the fixnum (ash ,integer ,(- position)))))
[6]	583	(t `(load-byte ,size ,position ,integer)))))
	584	((and (consp byte)
	585	(eq (%car byte) 'byte)
	586	(eq (list-length (%cdr byte)) 2))
	587	(let ((size (%cadr byte))
	588	(position (%caddr byte)))
	589	(if (and (nx-form-typep integer 'fixnum env) (fixnump position))
[4137]	590	;; I'm not sure this is worth doing
[5263]	591	`(logand (byte-mask ,size) (the fixnum (ash ,integer ,(- position))))
[4137]	592	;; this IS worth doing
[6]	593	`(load-byte ,size ,position ,integer))))
	594	(t call)))
	595
	596	(define-compiler-macro length (&whole call &environment env seq)
	597	(if (nx-form-typep seq '(simple-array * (*)) env)
	598	`(uvsize ,seq)
	599	call))
	600
	601	(define-compiler-macro let (&whole call (&optional (first nil first-p) &rest rest) &body body)
	602	(if first-p
	603	(if rest
	604	call
	605	`(let* (,first) ,@body))
	606	`(locally ,@body)))
	607
	608	(define-compiler-macro let* (&whole call (&rest bindings) &body body)
	609	(if bindings
	610	call
	611	`(locally ,@body)))
	612
	613	(define-compiler-macro list* (&whole call &environment env &rest rest &aux (n (list-length rest)) last)
	614	(cond ((%izerop n) nil)
	615	((null (setq last (%car (last call))))
	616	(cons 'list (nreverse (cdr (reverse (cdr call))))))
	617	((and (consp last) (memq (%car last) '(list* list cons)))
	618	(cons (if (eq (%car last) 'cons) 'list* (%car last))
	619	(nreconc (cdr (reverse (cdr call))) (%cdr last))))
	620	((eq n 1) (list 'values last))
	621	((eq n 2) (cons 'cons (%cdr call)))
	622	(t call)))
	623
	624
	625
[1989]	626	;;;(CONS X NIL) is same size as (LIST X) and faster.
[6]	627	(define-compiler-macro list (&whole call &optional (first nil first-p) &rest more)
	628	(if more
	629	call
	630	(if first-p
	631	`(cons ,first nil))))
	632
	633
	634	(define-compiler-macro locally (&whole call &body body &environment env)
	635	(multiple-value-bind (body decls) (parse-body body env nil)
	636	(if decls
	637	call
	638	`(progn ,@body))))
	639
[9338]	640	(defun specifier-type-if-known (typespec &optional env)
	641	(handler-case (specifier-type typespec env)
	642	(parse-unknown-type (c) (values nil (parse-unknown-type-specifier c)))
[9245]	643	(error () nil)))
[6]	644
[9390]	645	#+debugging-version
	646	(defun specifier-type-if-known (typespec &optional env)
	647	(handler-bind ((parse-unknown-type (lambda (c)
	648	(break "caught unknown-type ~s" c)
	649	(return-from specifier-type-if-known
	650	(values nil (parse-unknown-type-specifier c)))))
	651	(error (lambda (c)
	652	(break "caught error ~s" c)
	653	(return-from specifier-type-if-known nil))))
	654	(specifier-type typespec env)))
[9245]	655
[9390]	656
[9338]	657	(defun target-element-type-type-keyword (typespec &optional env)
	658	(let* ((ctype (specifier-type-if-known `(array ,typespec) env)))
[9245]	659	(if (null ctype)
[6]	660	(progn
	661	(nx1-whine :unknown-type-declaration typespec)
	662	nil)
[1373]	663	(funcall (arch::target-array-type-name-from-ctype-function
	664	(backend-target-arch target-backend))
	665	ctype))))
[6]	666
[5525]	667	(defun infer-array-type (dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)
	668	(let* ((ctype (make-array-ctype :complexp (or displaced-to-p fill-pointer-p adjustable-p))))
	669	(if (quoted-form-p dims)
	670	(let* ((dims (nx-unquote dims)))
	671	(if (listp dims)
	672	(progn
	673	(unless (every #'fixnump dims)
	674	(warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims))
	675	(setf (array-ctype-dimensions ctype) dims))
	676	(progn
	677	(unless (typep dims 'fixnum)
	678	(warn "Funky-looking array dimensions ~s in MAKE-ARRAY call" dims))
	679	(setf (array-ctype-dimensions ctype) (list dims)))))
	680	(if (atom dims)
	681	(if (nx-form-typep dims 'fixnum env)
	682	(setf (array-ctype-dimensions ctype)
	683	(if (typep (setq dims (nx-transform dims env)) 'fixnum)
	684	(list dims)
	685	(list '*)))
	686	(setf (array-ctype-dimensions ctype) '*))
	687	(if (eq (car dims) 'list)
	688	(setf (array-ctype-dimensions ctype)
	689	(mapcar #'(lambda (d)
	690	(if (typep (setq d (nx-transform d env)) 'fixnum)
	691	d
	692	'*))
	693	(cdr dims)))
	694	;; Wimp out
	695	(setf (array-ctype-dimensions ctype)
	696	'*))))
[10008]	697	(let* ((typespec (if element-type-p
	698	(if (constantp element-type)
	699	(nx-unquote element-type)
	700	'*)
	701	t))
[9338]	702	(element-type (or (specifier-type-if-known typespec env)
[9245]	703	(make-unknown-ctype :specifier typespec))))
[5525]	704	(setf (array-ctype-element-type ctype) element-type)
	705	(if (typep element-type 'unknown-ctype)
[10008]	706	(setf (array-ctype-element-type ctype) wild-type))
	707	(specialize-array-type ctype))
[5525]	708	(type-specifier ctype)))
	709
[9389]	710
	711
[6]	712	(define-compiler-macro make-array (&whole call &environment env dims &rest keys)
	713	(if (constant-keywords-p keys)
	714	(destructuring-bind (&key (element-type t element-type-p)
	715	(displaced-to () displaced-to-p)
	716	(displaced-index-offset () displaced-index-offset-p)
	717	(adjustable () adjustable-p)
	718	(fill-pointer () fill-pointer-p)
	719	(initial-element () initial-element-p)
[9389]	720	(initial-contents () initial-contents-p))
[5525]	721	keys
	722	(declare (ignorable element-type element-type-p
	723	displaced-to displaced-to-p
	724	displaced-index-offset displaced-index-offset-p
	725	adjustable adjustable-p
	726	fill-pointer fill-pointer-p
	727	initial-element initial-element-p
	728	initial-contents initial-contents-p))
	729	(let* ((element-type-keyword nil)
[9389]	730	(expansion
[5525]	731	(cond ((and initial-element-p initial-contents-p)
	732	(nx1-whine 'illegal-arguments call)
	733	call)
	734	(displaced-to-p
	735	(if (or initial-element-p initial-contents-p element-type-p)
	736	(comp-make-array-1 dims keys)
	737	(comp-make-displaced-array dims keys)))
[9389]	738	((or displaced-index-offset-p
[5525]	739	(not (constantp element-type))
	740	(null (setq element-type-keyword
	741	(target-element-type-type-keyword
[9338]	742	(eval element-type) env))))
[5525]	743	(comp-make-array-1 dims keys))
[9389]	744	((and (typep element-type-keyword 'keyword)
	745	(nx-form-typep dims 'fixnum env)
	746	(null (or adjustable fill-pointer initial-contents
	747	initial-contents-p)))
	748	(if
	749	(or (null initial-element-p)
	750	(cond ((eql element-type-keyword :double-float-vector)
	751	(eql initial-element 0.0d0))
	752	((eql element-type-keyword :single-float-vector)
	753	(eql initial-element 0.0s0))
	754	((eql element-type :simple-string)
[5525]	755	(eql initial-element #\Null))
	756	(t (eql initial-element 0))))
[9389]	757	`(allocate-typed-vector ,element-type-keyword ,dims)
	758	`(allocate-typed-vector ,element-type-keyword ,dims ,initial-element)))
[5525]	759	(t ;Should do more here
	760	(comp-make-uarray dims keys (type-keyword-code element-type-keyword)))))
	761	(type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)))
	762	`(the ,type ,expansion)))
[9389]	763
[5525]	764	call))
[6]	765
	766	(defun comp-make-displaced-array (dims keys)
	767	(let* ((call-list (make-list 4 :initial-element nil))
	768	(dims-var (make-symbol "DIMS"))
	769	(let-list (comp-nuke-keys keys
	770	'((:displaced-to 0)
	771	(:fill-pointer 1)
	772	(:adjustable 2)
	773	(:displaced-index-offset 3))
	774	call-list
	775	`((,dims-var ,dims)))))
	776
	777	`(let ,let-list
[609]	778	(%make-displaced-array ,dims-var ,@call-list t))))
[6]	779
	780	(defun comp-make-uarray (dims keys subtype)
[1373]	781	(if (null keys)
	782	`(%make-simple-array ,subtype ,dims)
	783	(let* ((call-list (make-list 6))
	784	(dims-var (make-symbol "DIMS"))
[10008]	785	(let-list (comp-nuke-keys keys
	786	'((:adjustable 0)
	787	(:fill-pointer 1)
	788	(:initial-element 2 3)
	789	(:initial-contents 4 5))
	790	call-list
	791	`((,dims-var ,dims)))))
	792	`(let ,let-list
	793	(make-uarray-1 ,subtype ,dims-var ,@call-list nil nil)))))
[6]	794
	795	(defun comp-make-array-1 (dims keys)
	796	(let* ((call-list (make-list 10 :initial-element nil))
	797	(dims-var (make-symbol "DIMS"))
[9389]	798	(let-list (comp-nuke-keys keys
[6]	799	'((:element-type 0 1)
	800	(:displaced-to 2)
	801	(:displaced-index-offset 3)
	802	(:adjustable 4)
	803	(:fill-pointer 5)
	804	(:initial-element 6 7)
	805	(:initial-contents 8 9))
	806	call-list
	807	`((,dims-var ,dims)))))
	808	`(let ,let-list
	809	(make-array-1 ,dims-var ,@call-list nil))))
	810
	811	(defun comp-nuke-keys (keys key-list call-list &optional required-bindings)
	812	; side effects call list, returns a let-list
[10008]	813	(let* ((let-list (reverse required-bindings))
	814	(seen nil))
[6]	815	(do ((lst keys (cddr lst)))
	816	((null lst) nil)
	817	(let* ((key (car lst))
	818	(val (cadr lst))
	819	(ass (assq key key-list))
	820	(vpos (cadr ass))
	821	(ppos (caddr ass)))
	822	(when ass
[10008]	823	(unless (memq vpos seen)
	824	(push vpos seen)
	825	(when (not (constantp val))
	826	(let ((gen (gensym)))
	827	(setq let-list (cons (list gen val) let-list)) ; reverse him
	828	(setq val gen)))
	829	(rplaca (nthcdr vpos call-list) val)
	830	(if ppos (rplaca (nthcdr ppos call-list) t))))))
[6]	831	(nreverse let-list)))
	832
	833	(define-compiler-macro make-instance (&whole call class &rest initargs)
	834	(if (and (listp class)
	835	(eq (car class) 'quote)
	836	(symbolp (cadr class))
	837	(null (cddr class)))
[7750]	838	(let* ((cell (gensym)))
	839	`(let* ((,cell (load-time-value (find-class-cell ,class t))))
	840	(funcall (class-cell-instantiate ,cell) ,cell ,@initargs)))
[6]	841	call))
	842
	843
	844
	845
	846
	847
[9389]	848
[6]	849	(define-compiler-macro mapc (&whole call fn lst &rest more)
	850	(if more
	851	call
	852	(let* ((temp-var (gensym))
	853	(elt-var (gensym))
	854	(fn-var (gensym)))
	855	`(let* ((,fn-var ,fn)
	856	(,temp-var ,lst))
	857	(dolist (,elt-var ,temp-var ,temp-var)
	858	(funcall ,fn-var ,elt-var))
	859	))))
	860
	861	(define-compiler-macro mapcar (&whole call fn lst &rest more)
	862	(if more
	863	call
	864	(let* ((temp-var (gensym))
	865	(result-var (gensym))
	866	(elt-var (gensym))
	867	(fn-var (gensym)))
	868	`(let* ((,temp-var (cons nil nil))
	869	(,result-var ,temp-var)
	870	(,fn-var ,fn))
	871	(declare (dynamic-extent ,temp-var)
	872	(type cons ,temp-var ,result-var))
	873	(dolist (,elt-var ,lst (cdr ,result-var))
	874	(setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var)))))))))
	875
[7624]	876	(define-compiler-macro member (&whole call item list &rest keys)
	877	(or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test)
[6]	878	call))
	879
[7624]	880	(define-compiler-macro memequal (&whole call &environment env item list)
	881	(if (or (equal-iff-eql-p item env)
	882	(and (quoted-form-p list)
	883	(proper-list-p (%cadr list))
	884	(every (lambda (elt) (equal-iff-eql-p elt env)) (%cadr list))))
	885	`(memeql ,item ,list)
	886	call))
[9389]	887
[7624]	888	(define-compiler-macro memeql (&whole call &environment env item list)
	889	(if (or (eql-iff-eq-p item env)
	890	(and (quoted-form-p list)
	891	(proper-list-p (%cadr list))
	892	(every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list))))
	893	`(memq ,item ,list)
	894	call))
	895
[6]	896	(define-compiler-macro memq (&whole call &environment env item list)
[7624]	897	;;(memq x '(y)) => (if (eq x 'y) '(y))
	898	;;Would it be worth making a two elt list into an OR? Maybe if
	899	;;optimizing for speed...
[6]	900	(if (and (or (quoted-form-p list)
	901	(null list))
	902	(null (cdr (%cadr list))))
	903	(if list `(if (eq ,item ',(%caadr list)) ,list))
[7624]	904	(let* ((x (gensym))
	905	(tail (gensym)))
	906	`(do* ((,x ,item)
	907	(,tail ,list (cdr (the list ,tail))))
	908	((null ,tail))
	909	(if (eq (car ,tail) ,x) (return ,tail))))))
[6]	910
	911	(define-compiler-macro minusp (x)
	912	`(< ,x 0))
	913
	914	(define-compiler-macro notany (&whole call &environment env &rest ignore)
	915	(declare (ignore ignore))
	916	(some-xx-transform call env))
	917
	918	(define-compiler-macro notevery (&whole call &environment env &rest ignore)
	919	(declare (ignore ignore))
	920	(some-xx-transform call env))
	921
	922	(define-compiler-macro nth (&whole call &environment env count list)
	923	(if (and (fixnump count)
	924	(%i>= count 0)
	925	(%i< count 3))
	926	`(,(svref '#(car cadr caddr) count) ,list)
[7624]	927	`(car (nthcdr ,count ,list))))
[6]	928
	929	(define-compiler-macro nthcdr (&whole call &environment env count list)
	930	(if (and (fixnump count)
	931	(%i>= count 0)
[9389]	932	(%i< count 4))
[6]	933	(if (%izerop count)
[7624]	934	`(require-type ,list 'list)
[6]	935	`(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list))
[7624]	936	(let* ((i (gensym))
	937	(n (gensym)) ; evaluation order
	938	(tail (gensym)))
	939	`(let* ((,n (require-type ,count 'unsigned-byte))
	940	(,tail (require-type ,list 'list)))
	941	(dotimes (,i ,n ,tail)
	942	(unless (setq ,tail (cdr ,tail))
	943	(return nil)))))))
[6]	944
	945	(define-compiler-macro plusp (x)
	946	`(> ,x 0))
	947
	948	(define-compiler-macro progn (&whole call &optional (first nil first-p) &rest rest)
	949	(if first-p
	950	(if rest call first)))
	951
[1989]	952	;;; This isn't quite right... The idea is that (car (require-type foo
	953	;;; 'list)) ;can become just (<typechecking-car> foo) [regardless of
	954	;;; optimize settings], ;but I don't think this can be done just with
	955	;;; optimizers... For now, at least try to get it to become (%car
	956	;;; (<typecheck> foo)).
[9245]	957	(define-compiler-macro require-type (&whole call &environment env arg type &aux ctype)
[8032]	958	(cond ((and (or (eq type t)
	959	(and (quoted-form-p type)
	960	(setq type (%cadr type))))
[9338]	961	(setq ctype (specifier-type-if-known type env)))
[6]	962	(cond ((nx-form-typep arg type env) arg)
	963	((eq type 'simple-vector)
	964	`(the simple-vector (require-simple-vector ,arg)))
	965	((eq type 'simple-string)
	966	`(the simple-string (require-simple-string ,arg)))
	967	((eq type 'integer)
	968	`(the integer (require-integer ,arg)))
	969	((eq type 'fixnum)
	970	`(the fixnum (require-fixnum ,arg)))
	971	((eq type 'real)
	972	`(the real (require-real ,arg)))
	973	((eq type 'list)
	974	`(the list (require-list ,arg)))
	975	((eq type 'character)
	976	`(the character (require-character ,arg)))
	977	((eq type 'number)
	978	`(the number (require-number ,arg)))
	979	((eq type 'symbol)
	980	`(the symbol (require-symbol ,arg)))
[9245]	981	((type= ctype
[5217]	982	(specifier-type '(signed-byte 8)))
[9389]	983	`(the (signed-byte 8) (require-s8 ,arg)))
[9245]	984	((type= ctype
[5217]	985	(specifier-type '(unsigned-byte 8)))
	986	`(the (unsigned-byte 8) (require-u8 ,arg)))
[9245]	987	((type= ctype
[5217]	988	(specifier-type '(signed-byte 16)))
	989	`(the (signed-byte 16) (require-s16 ,arg)))
[9245]	990	((type= ctype
[5217]	991	(specifier-type '(unsigned-byte 16)))
[9389]	992	`(the (unsigned-byte 16) (require-u16 ,arg)))
[9245]	993	((type= ctype
[5217]	994	(specifier-type '(signed-byte 32)))
	995	`(the (signed-byte 32) (require-s32 ,arg)))
[9245]	996	((type= ctype
[5217]	997	(specifier-type '(unsigned-byte 32)))
	998	`(the (unsigned-byte 32) (require-u32 ,arg)))
[9245]	999	((type= ctype
[5217]	1000	(specifier-type '(signed-byte 64)))
	1001	`(the (signed-byte 64) (require-s64 ,arg)))
[9245]	1002	((type= ctype
[5217]	1003	(specifier-type '(unsigned-byte 64)))
[8032]	1004	`(the (unsigned-byte 64) (require-u64 ,arg)))
	1005	#+nil
[6]	1006	((and (symbolp type)
	1007	(let ((simpler (type-predicate type)))
	1008	(if simpler `(the ,type (%require-type ,arg ',simpler))))))
[8032]	1009	#+nil
[6]	1010	((and (symbolp type)(find-class type nil env))
	1011	`(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
[7940]	1012	(t (let* ((val (gensym)))
	1013	`(let* ((,val ,arg))
	1014	(if (typep ,val ',type)
	1015	,val
	1016	(%kernel-restart $xwrongtype ,val ',type)))))))
[6]	1017	(t call)))
	1018
	1019	(define-compiler-macro proclaim (&whole call decl)
	1020	(if (and (quoted-form-p decl)
	1021	(eq (car (setq decl (%cadr decl))) 'special))
	1022	(do ((vars (%cdr decl) (%cdr vars)) (decls ()))
	1023	((null vars)
	1024	(cons 'progn (nreverse decls)))
	1025	(unless (and (car vars)
	1026	(neq (%car vars) t)
	1027	(symbolp (%car vars)))
	1028	(return call))
	1029	(push (list '%proclaim-special (list 'quote (%car vars))) decls))
	1030	call))
	1031
	1032
	1033	(define-compiler-macro some (&whole call &environment env &rest ignore)
	1034	(declare (ignore ignore))
	1035	(some-xx-transform call env))
	1036
	1037	(define-compiler-macro struct-ref (&whole call &environment env struct offset)
	1038	(if (nx-inhibit-safety-checking env)
	1039	`(%svref ,struct ,offset)
	1040	call))
	1041
	1042	;;; expand find-if and find-if-not
	1043
	1044	(define-compiler-macro find-if (&whole call &environment env
	1045	test sequence &rest keys)
	1046	`(find ,test ,sequence
	1047	:test #'funcall
	1048	,@keys))
	1049
	1050	(define-compiler-macro find-if-not (&whole call &environment env
	1051	test sequence &rest keys)
	1052	`(find ,test ,sequence
	1053	:test-not #'funcall
	1054	,@keys))
	1055
	1056	;;; inline some cases, and use a positional function in others
	1057
	1058	(define-compiler-macro find (&whole call &environment env
	1059	item sequence &rest keys)
	1060	(if (constant-keywords-p keys)
	1061	(destructuring-bind (&key from-end test test-not (start 0) end key) keys
	1062	(if (and (eql start 0)
	1063	(null end)
	1064	(null from-end)
	1065	(not (and test test-not)))
	1066	(let ((find-test (or test test-not '#'eql))
	1067	(loop-test (if test-not 'unless 'when))
	1068	(loop-function (nx-form-sequence-iterator sequence env)))
	1069	(if loop-function
	1070	(let ((item-var (unless (or (constantp item)
	1071	(and (equal find-test '#'funcall)
	1072	(function-form-p item)))
	1073	(gensym)))
	1074	(elt-var (gensym)))
	1075	`(let (,@(when item-var `((,item-var ,item))))
	1076	(,loop-function (,elt-var ,sequence)
	1077	(,loop-test (funcall ,find-test ,(or item-var item)
	1078	(funcall ,(or key '#'identity) ,elt-var))
	1079	(return ,elt-var)))))
	1080	(let ((find-function (if test-not 'find-positional-test-not-key 'find-positional-test-key))
	1081	(item-var (gensym))
	1082	(sequence-var (gensym))
	1083	(test-var (gensym))
	1084	(key-var (gensym)))
	1085	`(let ((,item-var ,item)
	1086	(,sequence-var ,sequence)
	1087	(,test-var ,(or test test-not))
	1088	(,key-var ,key))
	1089	(declare (dynamic-extent ,item-var ,sequence-var ,test-var ,key-var))
	1090	(,find-function ,item-var ,sequence-var ,test-var ,key-var)))))
	1091	call))
	1092	call))
	1093
	1094	;;; expand position-if and position-if-not
	1095
	1096	(define-compiler-macro position-if (&whole call &environment env
	1097	test sequence &rest keys)
	1098	`(position ,test ,sequence
	1099	:test #'funcall
	1100	,@keys))
	1101
	1102	(define-compiler-macro position-if-not (&whole call &environment env
	1103	test sequence &rest keys)
	1104	`(position ,test ,sequence
	1105	:test-not #'funcall
	1106	,@keys))
	1107
	1108	;;; inline some cases, and use positional functions for others
	1109
	1110	(define-compiler-macro position (&whole call &environment env
	1111	item sequence &rest keys)
	1112	(if (constant-keywords-p keys)
	1113	(destructuring-bind (&key from-end test test-not (start 0) end key) keys
	1114	(if (and (eql start 0)
	1115	(null end)
	1116	(null from-end)
	1117	(not (and test test-not)))
	1118	(let ((position-test (or test test-not '#'eql))
	1119	(loop-test (if test-not 'unless 'when))
	1120	(sequence-value (if (constantp sequence)
	1121	(eval-constant sequence)
	1122	sequence)))
	1123	(cond ((nx-form-typep sequence-value 'list env)
	1124	(let ((item-var (unless (or (constantp item)
	1125	(and (equal position-test '#'funcall)
	1126	(function-form-p item)))
	1127	(gensym)))
	1128	(elt-var (gensym))
	1129	(position-var (gensym)))
	1130	`(let (,@(when item-var `((,item-var ,item)))
	1131	(,position-var 0))
	1132	(dolist (,elt-var ,sequence)
	1133	(,loop-test (funcall ,position-test ,(or item-var item)
	1134	(funcall ,(or key '#'identity) ,elt-var))
	1135	(return ,position-var))
	1136	(incf ,position-var)))))
	1137	((nx-form-typep sequence-value 'vector env)
	1138	(let ((item-var (unless (or (constantp item)
	1139	(and (equal position-test '#'funcall)
	1140	(function-form-p item)))
	1141	(gensym)))
	1142	(sequence-var (gensym))
	1143	(position-var (gensym)))
	1144	`(let (,@(when item-var `((,item-var ,item)))
	1145	(,sequence-var ,sequence))
	1146	,@(let ((type (nx-form-type sequence env)))
	1147	(unless (eq type t)
	1148	`((declare (type ,type ,sequence-var)))))
	1149	(dotimes (,position-var (length ,sequence-var))
	1150	(,loop-test (funcall ,position-test ,(or item-var item)
	1151	(funcall ,(or key '#'identity)
	1152	(locally (declare (optimize (speed 3) (safety 0)))
	1153	(aref ,sequence ,position-var))))
	1154	(return ,position-var))))))
	1155	(t
	1156	(let ((position-function (if test-not
	1157	'position-positional-test-not-key
	1158	'position-positional-test-key))
	1159	(item-var (gensym))
	1160	(sequence-var (gensym))
	1161	(test-var (gensym))
	1162	(key-var (gensym)))
	1163	`(let ((,item-var ,item)
	1164	(,sequence-var ,sequence)
	1165	(,test-var ,(or test test-not))
	1166	(,key-var ,key))
	1167	(declare (dynamic-extent ,sequence-var ,test-var ,key-var))
	1168	(,position-function ,item-var ,sequence-var ,test-var ,key-var))))))
	1169	call))
	1170	call))
	1171
	1172	;;; inline some cases of remove-if and remove-if-not
	1173
	1174	(define-compiler-macro remove-if (&whole call &environment env &rest ignore)
	1175	(declare (ignore ignore))
	1176	(remove-if-transform call env))
	1177
	1178	(define-compiler-macro remove-if-not (&whole call &environment env &rest ignore)
	1179	(declare (ignore ignore))
	1180	(remove-if-transform call env))
	1181
	1182	(defun remove-if-transform (call env)
	1183	(destructuring-bind (function test sequence &rest keys) call
	1184	(if (constant-keywords-p keys)
	1185	(destructuring-bind (&key from-end (start 0) end count (key '#'identity)) keys
	1186	(if (and (eql start 0)
	1187	(null end)
	1188	(null from-end)
	1189	(null count)
	1190	(nx-form-typep sequence 'list env))
	1191	;; only do the list case, since it's hard to collect vector results
	1192	(let ((temp-var (gensym))
	1193	(result-var (gensym))
	1194	(elt-var (gensym))
	1195	(loop-test (ecase function (remove-if 'unless) (remove-if-not 'when))))
	1196	`(the list
	1197	(let* ((,temp-var (cons nil nil))
	1198	(,result-var ,temp-var))
	1199	(declare (dynamic-extent ,temp-var))
	1200	(dolist (,elt-var ,sequence (%cdr ,result-var))
	1201	(,loop-test (funcall ,test (funcall ,key ,elt-var))
[9389]	1202	(setq ,temp-var
	1203	(%cdr
[6]	1204	(%rplacd ,temp-var (list ,elt-var)))))))))
	1205	call))
	1206	call)))
	1207
	1208
	1209
	1210	(define-compiler-macro struct-set (&whole call &environment env struct offset new)
	1211	(if (nx-inhibit-safety-checking env)
	1212	`(%svset ,struct ,offset ,new)
	1213	call))
	1214
	1215	(define-compiler-macro zerop (arg &environment env)
	1216	(let* ((z (if (nx-form-typep arg 'float env)
	1217	(coerce 0 (nx-form-type arg env))
	1218	0)))
	1219	`(= ,arg ,z)))
	1220
	1221
	1222	(define-compiler-macro = (&whole w n0 &optional (n1 nil n1p) &rest more)
	1223	(if (not n1p)
	1224	`(require-type ,n0 'number)
	1225	(if more
	1226	w
	1227	`(=-2 ,n0 ,n1))))
	1228
	1229	(define-compiler-macro /= (&whole w n0 &optional (n1 nil n1p) &rest more)
	1230	(if (not n1p)
	1231	`(require-type ,n0 'number)
	1232	(if more
	1233	w
	1234	`(/=-2 ,n0 ,n1))))
	1235
	1236	(define-compiler-macro + (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
	1237	(if more
[1733]	1238	`(+ (+-2 ,n0 ,n1) ,@more)
[6]	1239	(if n1p
	1240	`(+-2 ,n0 ,n1)
	1241	(if n0p
	1242	`(require-type ,n0 'number)
	1243	0))))
	1244
	1245	(define-compiler-macro - (&whole w &environment env n0 &optional (n1 nil n1p) &rest more)
	1246	(if more
[1733]	1247	`(- (--2 ,n0 ,n1) ,@more)
[6]	1248	(if n1p
	1249	`(--2 ,n0 ,n1)
	1250	`(%negate ,n0))))
	1251
	1252	(define-compiler-macro * (&whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
	1253	(if more
	1254	(let ((type (nx-form-type w env)))
	1255	(if (and type (numeric-type-p type)) ; go pairwise if type known, else not
	1256	`(-2 ,n0 ( ,n1 ,@more))
	1257	w))
	1258	(if n1p
	1259	`(*-2 ,n0 ,n1)
	1260	(if n0p
	1261	`(require-type ,n0 'number)
	1262	1))))
	1263
	1264	(define-compiler-macro / (&whole w n0 &optional (n1 nil n1p) &rest more)
	1265	(if more
	1266	w
	1267	(if n1p
	1268	`(/-2 ,n0 ,n1)
	1269	`(%quo-1 ,n0))))
	1270
[1989]	1271	;;; beware of limits - truncate of most-negative-fixnum & -1 ain't a
	1272	;;; fixnum - too bad
[6]	1273	(define-compiler-macro truncate (&whole w &environment env n0 &optional (n1 nil n1p))
	1274	(let ((nx-form-type t))
	1275	(if (nx-form-typep n0 'fixnum env)
	1276	(if (not n1p)
	1277	n0
	1278	(if (nx-form-typep n1 'fixnum env)
	1279	`(%fixnum-truncate ,n0 ,n1)
	1280	w))
	1281	w)))
	1282
	1283	(define-compiler-macro floor (&whole w &environment env n0 &optional (n1 nil n1p))
	1284	(let ((nx-form-type t))
	1285	(if (nx-form-typep n0 'fixnum env)
	1286	(if (not n1p)
	1287	n0
	1288	(if (nx-form-typep n1 'fixnum env)
	1289	`(%fixnum-floor ,n0 ,n1)
	1290	w))
	1291	w)))
	1292
	1293	(define-compiler-macro round (&whole w &environment env n0 &optional (n1 nil n1p))
	1294	(let ((nx-form-type t)) ; it doesn't matter what the result type is declared to be
	1295	(if (nx-form-typep n0 'fixnum env)
	1296	(if (not n1p)
	1297	n0
	1298	(if (nx-form-typep n1 'fixnum env)
	1299	`(%fixnum-round ,n0 ,n1)
	1300	w))
	1301	w)))
	1302
	1303	(define-compiler-macro ceiling (&whole w &environment env n0 &optional (n1 nil n1p))
	1304	(let ((nx-form-type t))
	1305	(if (nx-form-typep n0 'fixnum env)
	1306	(if (not n1p)
	1307	n0
	1308	(if (nx-form-typep n1 'fixnum env)
	1309	`(%fixnum-ceiling ,n0 ,n1)
	1310	w))
	1311	w)))
	1312
	1313	(define-compiler-macro oddp (&whole w &environment env n0)
	1314	(if (nx-form-typep n0 'fixnum env)
	1315	`(logbitp 0 (the fixnum ,n0))
	1316	w))
	1317
	1318	(define-compiler-macro evenp (&whole w &environment env n0)
	1319	(if (nx-form-typep n0 'fixnum env)
	1320	`(not (logbitp 0 (the fixnum ,n0)))
	1321	w))
	1322
[9389]	1323
[6]	1324	(define-compiler-macro logandc2 (n0 n1)
	1325	(let ((n1var (gensym))
	1326	(n0var (gensym)))
	1327	`(let ((,n0var ,n0)
	1328	(,n1var ,n1))
	1329	(logandc1 ,n1var ,n0var))))
	1330
	1331	(define-compiler-macro logorc2 (n0 n1)
	1332	(let ((n1var (gensym))
	1333	(n0var (gensym)))
	1334	`(let ((,n0var ,n0)
	1335	(,n1var ,n1))
	1336	(logorc1 ,n1var ,n0var))))
	1337
	1338	(define-compiler-macro lognand (n0 n1)
	1339	`(lognot (logand ,n0 ,n1)))
	1340
	1341	(define-compiler-macro lognor (n0 n1)
	1342	`(lognot (logior ,n0 ,n1)))
	1343
	1344
[1907]	1345	(defun transform-logop (whole identity binop &optional (transform-complement t))
[6]	1346	(destructuring-bind (op &optional (n0 nil n0p) (n1 nil n1p) &rest more) whole
	1347	(if (and n1p (eql n0 identity))
	1348	`(,op ,n1 ,@more)
[1907]	1349	(if (and transform-complement n1p (eql n0 (lognot identity)))
[6]	1350	`(progn
	1351	(,op ,n1 ,@more)
	1352	,(lognot identity))
	1353	(if more
	1354	(if (cdr more)
	1355	whole
	1356	`(,binop ,n0 (,binop ,n1 ,(car more))))
	1357	(if n1p
	1358	`(,binop ,n0 ,n1)
	1359	(if n0p
	1360	`(require-type ,n0 'integer)
	1361	identity)))))))
[9389]	1362
[6]	1363	(define-compiler-macro logand (&whole w &rest all)
	1364	(declare (ignore all))
	1365	(transform-logop w -1 'logand-2))
	1366
	1367	(define-compiler-macro logior (&whole w &rest all)
	1368	(declare (ignore all))
	1369	(transform-logop w 0 'logior-2))
	1370
	1371	(define-compiler-macro logxor (&whole w &rest all)
	1372	(declare (ignore all))
[1907]	1373	(transform-logop w 0 'logxor-2 nil))
[6]	1374
	1375	(define-compiler-macro lognot (&whole w &environment env n1)
	1376	(if (nx-form-typep n1 'fixnum env)
	1377	`(%ilognot ,n1)
	1378	w))
	1379
	1380	(define-compiler-macro logtest (&whole w &environment env n1 n2)
	1381	(if (and (nx-form-typep n1 'fixnum env)
	1382	(nx-form-typep n2 'fixnum env))
	1383	`(not (eql 0 (logand ,n1 ,n2)))
	1384	w))
	1385
[9389]	1386
[6]	1387	(defmacro defsynonym (from to)
	1388	;Should maybe check for circularities.
	1389	`(progn
	1390	(setf (compiler-macro-function ',from) nil)
	1391	(let ((pair (assq ',from nx-synonyms)))
[9389]	1392	(if pair (rplacd pair ',to)
	1393	(push (cons ',from ',to)
[6]	1394	nx-synonyms))
	1395	',to)))
	1396
	1397	(defsynonym first car)
	1398	(defsynonym second cadr)
	1399	(defsynonym third caddr)
	1400	(defsynonym fourth cadddr)
	1401	(defsynonym rest cdr)
	1402
	1403
	1404	(defsynonym functionp lfunp)
	1405	(defsynonym null not)
	1406	(defsynonym char-int char-code)
	1407
	1408	;;; Improvemets file by Bob Cassels
	1409	;;; Just what are "Improvemets", anyway ?
	1410
[1989]	1411	;;; Optimize some CL sequence functions, mostly by inlining them in
	1412	;;; simple cases when the type of the sequence is known. In some
	1413	;;; cases, dynamic-extent declarations are automatically inserted.
	1414	;;; For some sequence functions, if the type of the sequence is known
	1415	;;; at compile time, the function is inlined. If the type isn't known
	1416	;;; but the call is "simple", a call to a faster (positional-arg)
[6]	1417	;;; function is substituted.
	1418
	1419
	1420	(defun nx-form-sequence-iterator (sequence-form env)
	1421	(cond ((nx-form-typep sequence-form 'vector env) 'dovector)
	1422	((nx-form-typep sequence-form 'list env) 'dolist)))
	1423
	1424	(defun function-form-p (form)
	1425	;; c.f. quoted-form-p
	1426	(and (consp form)
	1427	(eq (%car form) 'function)
	1428	(consp (%cdr form))
	1429	(null (%cdr (%cdr form)))))
	1430
[7940]	1431
	1432	;; Return a form that checks to see if THING is if type CTYPE, or
	1433	;; NIL if we can't do that for some reason.
	1434	(defun optimize-ctypep (thing ctype)
	1435	(when (eq target-backend host-backend)
	1436	(typecase ctype
	1437	(numeric-ctype
	1438	(cond ((eq :real (numeric-ctype-complexp ctype))
	1439	(let* ((low (numeric-ctype-low ctype))
	1440	(high (numeric-ctype-high ctype))
	1441	(class (numeric-ctype-class ctype))
	1442	(format (numeric-ctype-format ctype))
	1443	(type (if (eq class 'float)
	1444	(or format class)
[8970]	1445	(or class 'real))))
[7940]	1446	(cond ((and low (eql low high) (or (not (eq class 'float))
	1447	format))
	1448	`(eql ,thing ,low))
	1449	((and (eq type 'float)
	1450	(or low high)
	1451	(or (null low)
	1452	(typep low 'single-float)
	1453	(not (null (ignore-errors
	1454	(coerce (if (atom low)
	1455	low
	1456	(car low))
	1457	'single-float)))))
	1458	(or (null high)
	1459	(typep high 'single-float)
	1460	(not (null (ignore-errors
	1461	(coerce (if (atom high)
	1462	high
	1463	(car high))
	1464	'single-float))))))
	1465	(let* ((temp (gensym)))
	1466	(flet ((bounded-float (type low high)
	1467	`(,type
	1468	,(if low
	1469	(if (listp low)
	1470	(list (coerce (car low) type))
	1471	(coerce low type))
	1472	'*)
	1473	,(if high
	1474	(if (listp high)
	1475	(list (coerce (car high) type))
	1476	(coerce high type))
	1477	'*))))
	1478	`(let* ((,temp ,thing))
	1479	(or (typep ,temp ',(bounded-float 'single-float low high))
	1480	(typep ,temp ',(bounded-float 'double-float low high)))))))
	1481	(t
	1482	(let* ((temp (gensym)))
[8970]	1483	(if (and (typep low 'fixnum) (typep high 'fixnum)
	1484	(eq class 'integer))
[7940]	1485	(setq type 'fixnum))
	1486	(if (or low high)
	1487	`(let* ((,temp ,thing))
	1488	(and (typep ,temp ',type)
	1489	,@(if low `((,(if (consp low) '> '>=) (the ,type ,temp) ,(if (consp low) (car low) low))))
	1490	,@(if high `((,(if (consp high) '< '<=) (the ,type ,temp) ,(if (consp high) (car high) high))))))
	1491	`(typep ,thing ',type)))))))
	1492	(t `(numeric-%%typep ,thing ,ctype))))
	1493	(array-ctype
	1494	(or
	1495	(let* ((typecode (array-ctype-typecode ctype))
	1496	(dims (array-ctype-dimensions ctype)))
	1497	(cond ((and typecode (consp dims) (null (cdr dims)))
	1498	(case (array-ctype-complexp ctype)
	1499	((nil)
	1500	(if (eq (car dims) '*)
	1501	`(eql (typecode ,thing) ,typecode)
	1502	(let* ((temp (gensym)))
	1503	`(let* ((,temp ,thing))
	1504	(and (eql (typecode ,temp) ,typecode)
	1505	(eq (uvsize ,temp) ,(car dims)))))))
	1506	((* :maybe)
	1507	(let* ((temp (gensym))
	1508	(tempcode (gensym)))
	1509	`(let* ((,temp ,thing)
	1510	(,tempcode (typecode ,temp)))
	1511	(or (and (eql ,tempcode ,typecode)
	1512	,@(unless (eq (car dims) '*)
[7961]	1513	`((eq (uvsize ,temp) ,(car dims)))))
[7940]	1514	(and (eql ,tempcode target::subtag-vectorH)
	1515	(eql (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,temp target::arrayH.flags-cell))) ,typecode)
	1516	,@(unless (eq (car dims) '*)
	1517	`((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims)))))))))))))
[10008]	1518	`(values (array-%%typep ,thing ,ctype)))))))
[7940]	1519
[9389]	1520
	1521
[6]	1522	(defun optimize-typep (thing type env)
	1523	;; returns a new form, or nil if it can't optimize
[9338]	1524	(let* ((ctype (specifier-type-if-known type env)))
[9245]	1525	(when ctype
[7940]	1526	(let* ((type (type-specifier ctype))
	1527	(predicate (if (typep type 'symbol) (type-predicate type))))
	1528	(if (and predicate (symbolp predicate))
	1529	`(,predicate ,thing)
[9938]	1530	(let* ((pair (assq type istruct-cells))
	1531	(class (and pair (%wrapper-class (istruct-cell-info pair)))))
	1532	(if (and class (not (%class-direct-subclasses class)))
	1533	`(istruct-typep ,thing ',type)
	1534	(or (optimize-ctypep thing ctype)
	1535	(cond ((symbolp type)
	1536	(cond ((%deftype-expander type)
	1537	;; recurse here, rather than returning the
	1538	;; partially-expanded form mostly since it doesn't
	1539	;; seem to further optimize the result otherwise
	1540	(let ((expanded-type (type-expand type)))
	1541	(or (optimize-typep thing expanded-type env)
	1542	;; at least do the first expansion
	1543	`(typep ,thing ',expanded-type))))
	1544	((structure-class-p type env)
	1545	`(structure-typep ,thing ',(find-class-cell type t)))
	1546	((find-class type nil env)
	1547	(let* ((class (find-class type nil nil))
	1548	(fname
	1549	(if (or (null class)
	1550	(and (subtypep class 'standard-object)
	1551	(not (subtypep class 'foreign-standard-object))))
	1552	'std-instance-class-cell-typep
	1553	'class-cell-typep)))
	1554	`(,fname ,thing (load-time-value (find-class-cell ',type t)))))
	1555	((info-type-builtin type) ; bootstrap troubles here?
	1556	`(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
	1557	(t nil)))
	1558	((consp type)
	1559	(cond
	1560	((info-type-builtin type) ; byte types
[7940]	1561	`(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
[9938]	1562	(t
	1563	(case (%car type)
	1564	(satisfies `(funcall ',(cadr type) ,thing))
	1565	(eql `(eql ,thing ',(cadr type)))
	1566	(member `(not (null (member ,thing ',(%cdr type)))))
	1567	(not `(not (typep ,thing ',(cadr type))))
	1568	((or and)
	1569	(let ((thing-sym (gensym)))
	1570	`(let ((,thing-sym ,thing))
	1571	(,(%car type)
	1572	,@(mapcar #'(lambda (type-spec)
	1573	(or (optimize-typep thing-sym type-spec env)
	1574	`(typep ,thing-sym ',type-spec)))
	1575	(%cdr type))))))
	1576	((signed-byte unsigned-byte integer mod) ; more byte types
	1577	`(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
	1578	(t nil)))))
	1579	(t nil))))))))))
[6]	1580
	1581	(define-compiler-macro typep (&whole call &environment env thing type &optional e)
	1582	(if (quoted-form-p type)
[9338]	1583	(if (and (constantp thing) (specifier-type-if-known type env))
[9360]	1584	(typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type) env)
	1585	(or (and (null e) (optimize-typep thing (%cadr type) env))
[8032]	1586	call))
[7940]	1587	(if (eq type t)
	1588	`(progn ,thing t)
	1589	call)))
[6]	1590
[9578]	1591	(define-compiler-macro structure-typep (&whole w thing type)
	1592	(if (not (quoted-form-p type))
	1593	(progn
	1594	(warn "Non-qouted structure-type in ~s" w)
	1595	w)
	1596	(let* ((type (nx-unquote type)))
	1597	(if (symbolp type)
	1598	`(structure-typep ,thing ',(find-class-cell type t))
	1599	w))))
	1600
[2052]	1601	(define-compiler-macro true (&rest args)
	1602	`(progn
	1603	,@args
	1604	t))
[6]	1605
	1606
[2052]	1607	(define-compiler-macro false (&rest args)
	1608	`(progn
	1609	,@args
	1610	nil))
	1611
[6]	1612	(define-compiler-macro find-class (&whole call type &optional (errorp t) env)
	1613	(if (and (quoted-form-p type)(not dont-find-class-optimize)(not env))
	1614	`(class-cell-find-class (load-time-value (find-class-cell ,type t)) ,errorp)
	1615	call))
	1616
	1617
	1618	(define-compiler-macro gcd (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
	1619	(if rest
	1620	call
	1621	(if n1-p
	1622	`(gcd-2 ,n0 ,n1)
	1623	(if n0-p
	1624	`(%integer-abs ,n0)
	1625	0))))
	1626
	1627	(define-compiler-macro lcm (&whole call &optional (n0 nil n0-p) (n1 nil n1-p) &rest rest)
	1628	(if rest
	1629	call
	1630	(if n1-p
	1631	`(lcm-2 ,n0 ,n1)
	1632	(if n0-p
	1633	`(%integer-abs ,n0)
	1634	1))))
	1635
	1636	(define-compiler-macro max (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
	1637	(if rest
	1638	call
	1639	(if n1-p
	1640	(if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
	1641	`(imax-2 ,n0 ,n1)
	1642	`(max-2 ,n0 ,n1))
	1643	`(require-type ,n0 'real))))
	1644
	1645	(define-compiler-macro max-2 (n0 n1)
	1646	(let* ((g0 (gensym))
	1647	(g1 (gensym)))
	1648	`(let* ((,g0 ,n0)
	1649	(,g1 ,n1))
	1650	(if (> ,g0 ,g1) ,g0 ,g1))))
	1651
	1652	(define-compiler-macro imax-2 (n0 n1)
	1653	(let* ((g0 (gensym))
	1654	(g1 (gensym)))
	1655	`(let* ((,g0 ,n0)
	1656	(,g1 ,n1))
	1657	(if (%i> ,g0 ,g1) ,g0 ,g1))))
	1658
	1659
	1660
	1661
	1662	(define-compiler-macro min (&whole call &environment env n0 &optional (n1 nil n1-p) &rest rest)
	1663	(if rest
	1664	call
	1665	(if n1-p
	1666	(if (and (nx-form-typep n0 'fixnum env)(nx-form-typep n1 'fixnum env))
	1667	`(imin-2 ,n0 ,n1)
	1668	`(min-2 ,n0 ,n1))
	1669	`(require-type ,n0 'real))))
	1670
	1671	(define-compiler-macro min-2 (n0 n1)
	1672	(let* ((g0 (gensym))
	1673	(g1 (gensym)))
	1674	`(let* ((,g0 ,n0)
	1675	(,g1 ,n1))
	1676	(if (< ,g0 ,g1) ,g0 ,g1))))
	1677
	1678	(define-compiler-macro imin-2 (n0 n1)
	1679	(let* ((g0 (gensym))
	1680	(g1 (gensym)))
	1681	`(let* ((,g0 ,n0)
	1682	(,g1 ,n1))
	1683	(if (%i< ,g0 ,g1) ,g0 ,g1))))
	1684
	1685
	1686	(defun eq-test-p (test)
	1687	(or (equal test ''eq) (equal test '#'eq)))
	1688
	1689	(defun eql-test-p (test)
	1690	(or (equal test ''eql) (equal test '#'eql)))
	1691
	1692	(define-compiler-macro adjoin (&whole whole elt list &rest keys)
	1693	(if (constant-keywords-p keys)
	1694	(destructuring-bind (&key (test ''eql) test-not key) keys
	1695	(or (and (null test-not)
	1696	(null key)
	1697	(cond ((eq-test-p test)
	1698	`(adjoin-eq ,elt ,list))
	1699	((eql-test-p test)
	1700	`(adjoin-eql ,elt ,list))
	1701	(t nil)))
	1702	whole))
	1703	whole))
	1704
	1705	(define-compiler-macro union (&whole whole list1 list2 &rest keys)
	1706	(if (constant-keywords-p keys)
	1707	(destructuring-bind (&key (test ''eql) test-not key) keys
	1708	(or (and (null test-not)
	1709	(null key)
	1710	(cond ((eq-test-p test)
	1711	`(union-eq ,list1 ,list2))
	1712	((eql-test-p test)
	1713	`(union-eql ,list1 ,list2))
	1714	(t nil)))
	1715	whole))
	1716	whole))
	1717
	1718	(define-compiler-macro slot-value (&whole whole &environment env
	1719	instance slot-name-form)
[97]	1720	(declare (ignore env))
	1721	(let* ((name (and (quoted-form-p slot-name-form)
	1722	(typep (cadr slot-name-form) 'symbol)
	1723	(cadr slot-name-form))))
	1724	(if name
	1725	`(slot-id-value ,instance (load-time-value (ensure-slot-id ',name)))
	1726	whole)))
[6]	1727
[97]	1728
[6]	1729	(define-compiler-macro set-slot-value (&whole whole &environment env
	1730	instance slot-name-form value-form)
[97]	1731	(declare (ignore env))
	1732	(let* ((name (and (quoted-form-p slot-name-form)
	1733	(typep (cadr slot-name-form) 'symbol)
	1734	(cadr slot-name-form))))
	1735	(if name
	1736	`(set-slot-id-value
	1737	,instance
	1738	(load-time-value (ensure-slot-id ',name))
	1739	,value-form)
	1740	whole)))
[6]	1741
	1742
[9578]	1743	(define-compiler-macro slot-boundp (&whole whole instance slot-name-form)
	1744	(let* ((name (and (quoted-form-p slot-name-form)
	1745	(typep (cadr slot-name-form) 'symbol)
	1746	(cadr slot-name-form))))
	1747	(if name
	1748	`(slot-id-boundp ,instance (load-time-value (ensure-slot-id ',name)))
	1749	whole)))
[97]	1750
[6]	1751	(defsynonym %get-unsigned-byte %get-byte)
	1752	(defsynonym %get-unsigned-word %get-word)
	1753	(defsynonym %get-signed-long %get-long)
	1754
	1755
	1756
	1757
	1758	(define-compiler-macro arrayp (arg)
[1334]	1759	`(>= (the fixnum (typecode ,arg))
[3228]	1760	,(nx-lookup-target-uvector-subtag :array-header)))
[6]	1761
	1762	(define-compiler-macro vectorp (arg)
[1334]	1763	`(>= (the fixnum (typecode ,arg))
[3228]	1764	,(nx-lookup-target-uvector-subtag :vector-header)))
[6]	1765
	1766
[3228]	1767
[6]	1768	(define-compiler-macro fixnump (arg)
[3228]	1769	(let* ((fixnum-tag
	1770	(arch::target-fixnum-tag (backend-target-arch target-backend))))
	1771	`(eql (lisptag ,arg) ,fixnum-tag)))
[6]	1772
	1773
[6177]	1774
[6]	1775	(define-compiler-macro double-float-p (n)
[3228]	1776	(let* ((tag (arch::target-double-float-tag (backend-target-arch target-backend))))
	1777	`(eql (typecode ,n) ,tag)))
[6]	1778
	1779
	1780	(define-compiler-macro short-float-p (n)
[3228]	1781	(let* ((arch (backend-target-arch target-backend))
	1782	(tag (arch::target-single-float-tag arch))
	1783	(op (if (arch::target-single-float-tag-is-subtag arch)
	1784	'typecode
	1785	'fulltag)))
	1786	`(eql (,op ,n) ,tag)))
[6]	1787
	1788
	1789	(define-compiler-macro floatp (n)
[3228]	1790	(let* ((typecode (make-symbol "TYPECODE"))
	1791	(arch (backend-target-arch target-backend))
	1792	(single (arch::target-single-float-tag arch))
	1793	(double (arch::target-double-float-tag arch)))
[6]	1794	`(let* ((,typecode (typecode ,n)))
	1795	(declare (fixnum ,typecode))
[3228]	1796	(or (= ,typecode ,single)
	1797	(= ,typecode ,double)))))
[6]	1798
	1799	(define-compiler-macro functionp (n)
[3228]	1800	(let* ((arch (backend-target-arch target-backend))
	1801	(tag (arch::target-function-tag arch))
	1802	(op (if (arch::target-function-tag-is-subtag arch)
	1803	'typecode
	1804	'fulltag)))
	1805	`(eql (,op ,n) ,tag)))
[6]	1806
[1615]	1807	(define-compiler-macro symbolp (s)
[3228]	1808	(let* ((arch (backend-target-arch target-backend))
	1809	(symtag (arch::target-symbol-tag arch))
	1810	(op (if (arch::target-symbol-tag-is-subtag arch)
	1811	'typecode
	1812	'fulltag))
	1813	(niltag (arch::target-null-tag arch)))
	1814	(if (eql niltag symtag)
	1815	`(eql (,op ,s) ,symtag)
	1816	(let* ((sym (gensym)))
	1817	`(let* ((,sym ,s))
	1818	(if ,sym (eql (,op ,sym) ,symtag) t))))))
	1819
	1820	;;; If NIL isn't tagged as a symbol, assume that LISPTAG only looks
	1821	;;; at bits that NIL shares with a cons.
[6]	1822	(define-compiler-macro listp (n)
[3228]	1823	(let* ((arch (backend-target-arch target-backend))
	1824	(cons-tag (arch::target-cons-tag arch))
	1825	(nil-tag (arch::target-null-tag arch))
	1826	(symbol-tag (arch::target-symbol-tag arch)))
	1827	(if (= nil-tag symbol-tag)
	1828	(let* ((nvar (gensym)))
	1829	`(let* ((,nvar ,n))
	1830	(if ,nvar (consp ,nvar) t)))
	1831	`(eql (lisptag ,n) ,cons-tag))))
[6]	1832
	1833	(define-compiler-macro consp (n)
[3228]	1834	(let* ((cons-tag (arch::target-cons-tag (backend-target-arch target-backend))))
	1835	`(eql (fulltag ,n) ,cons-tag)))
[6]	1836
	1837	(define-compiler-macro bignump (n)
[3228]	1838	`(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :bignum)))
[6]	1839
	1840	(define-compiler-macro ratiop (n)
[3228]	1841	`(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :ratio)))
[6]	1842
	1843	(define-compiler-macro complexp (n)
[3228]	1844	`(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :complex)))
[6]	1845
[3876]	1846	(define-compiler-macro macptrp (n)
	1847	`(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :macptr)))
[6]	1848
[4910]	1849	(define-compiler-macro basic-stream-p (n)
	1850	`(eql (typecode ,n) ,(nx-lookup-target-uvector-subtag :basic-stream)))
	1851
[6]	1852	(define-compiler-macro aref (&whole call a &rest subscripts &environment env)
[3228]	1853	(let* ((ctype (if (nx-form-typep a 'array env)
[9338]	1854	(specifier-type (nx-form-type a env) env)))
[3228]	1855	(type (if ctype (type-specifier (array-ctype-specialized-element-type ctype))))
	1856	(useful (unless (or (eq type *) (eq type t))
[9389]	1857	type)))
[3228]	1858	(if (= 2 (length subscripts))
[5516]	1859	(setq call `(%aref2 ,a ,@subscripts))
	1860	(if (= 3 (length subscripts))
	1861	(setq call `(%aref3 ,a ,@subscripts))))
[3228]	1862	(if useful
	1863	`(the ,useful ,call)
	1864	call)))
[6]	1865
	1866
	1867	(define-compiler-macro aset (&whole call a &rest subs&val)
	1868	(if (= 3 (length subs&val))
[5516]	1869	`(%aset2 ,a ,@subs&val)
	1870	(if (= 4 (length subs&val))
	1871	`(%aset3 ,a ,@subs&val)
	1872	call)))
[6]	1873
	1874
	1875	(define-compiler-macro make-sequence (&whole call &environment env typespec len &rest keys &key initial-element)
	1876	(declare (ignore typespec len keys initial-element))
	1877	call)
	1878
	1879	(define-compiler-macro make-string (&whole call size &rest keys)
	1880	(if (constant-keywords-p keys)
	1881	(destructuring-bind (&key (element-type () element-type-p)
	1882	(initial-element () initial-element-p))
	1883	keys
	1884	(if (and element-type-p
	1885	(quoted-form-p element-type))
	1886	(let* ((element-type (cadr element-type)))
	1887	(if (subtypep element-type 'base-char)
[1334]	1888	`(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
[6]	1889	call))
	1890	(if (not element-type-p)
[1334]	1891	`(allocate-typed-vector :simple-string ,size ,@(if initial-element-p `(,initial-element)))
[6]	1892	call)))
	1893	call))
	1894
[5404]	1895	(define-compiler-macro make-string-output-stream (&whole whole &rest keys)
	1896	(if (null keys)
	1897	'(make-simple-string-output-stream)
	1898	whole))
	1899
	1900
[9464]	1901	(define-compiler-macro write-string (&environment env &whole call
	1902	string &optional (stream nil) &rest keys)
	1903	(if (nx-form-typep string 'simple-string env)
	1904	(if keys
	1905	`((lambda (string stream &key start end)
	1906	(write-simple-string string stream start end))
	1907	,string ,stream ,@keys)
	1908	`(write-simple-string ,string ,stream 0 nil))
	1909	call))
	1910
	1911	(define-compiler-macro format (&environment env &whole call stream string &rest args)
	1912	(if (stringp string)
	1913	(cond ((string-equal string "~a")
	1914	(destructuring-bind (object) args
	1915	(cond ((null stream)
	1916	`(princ-to-string ,object))
	1917	((or (eq stream t) (nx-form-typep stream 'stream env))
[9483]	1918	`(progn (princ ,object ,(and (neq stream t) stream)) nil))
[9464]	1919	(t `(let ((stream ,stream)
	1920	(object ,object))
	1921	(if (or (null stream) (stringp stream))
	1922	(format-to-string stream ,string object)
[9483]	1923	(progn (princ object (and (neq stream t) stream)) nil)))))))
[9464]	1924	((string-equal string "~s")
	1925	(destructuring-bind (object) args
	1926	(cond ((null stream)
	1927	`(prin1-to-string ,object))
	1928	((or (eq stream t) (nx-form-typep stream 'stream env))
[9483]	1929	`(progn (prin1 ,object ,(and (neq stream t) stream)) nil))
[9464]	1930	(t `(let ((stream ,stream)
	1931	(object ,object))
	1932	(if (or (null stream) (stringp stream))
	1933	(format-to-string stream ,string object)
[9483]	1934	(progn (prin1 object (and (neq stream t) stream)) nil)))))))
[9464]	1935	((and (null (position #\~ string)) (null args))
	1936	(cond ((null stream)
	1937	string)
	1938	((or (eq stream t) (nx-form-typep stream 'stream env))
[9483]	1939	`(progn (write-string ,string ,(and (neq stream t) stream)) nil))
[9464]	1940	(t `(let ((stream ,stream))
	1941	(if (or (null stream) (stringp stream))
	1942	(format-to-string stream ,string)
[9483]	1943	(progn (write-string ,string (and (neq stream t) stream)) nil))))))
	1944	((optimize-format-call stream string args env))
[9464]	1945	(t call))
	1946	call))
	1947
[9483]	1948	(defun count-known-format-args (string start end)
	1949	(declare (fixnum start end))
	1950	(loop with count = 0
	1951	do (setq start (position #\~ string :start start :end end))
	1952	when (null start)
	1953	do (return count)
	1954	unless (< (incf start) end)
	1955	do (return nil)
	1956	do (let ((ch (aref string start)))
	1957	(cond ((memq ch '(#\a #\A #\s #\S)) (incf count))
	1958	((memq ch '(#\~ #\% #\&)))
	1959	(t (return nil)))
	1960	(incf start))))
	1961
	1962	(defun optimize-format-call (stream string args env)
	1963	(let* ((start (or (search "~/" string)
	1964	(return-from optimize-format-call nil)))
[9464]	1965	(ipos (+ start 2))
[9483]	1966	(epos (or (position #\/ string :start ipos)
	1967	(return-from optimize-format-call nil)))
	1968	(nargs (or (count-known-format-args string 0 start)
	1969	(return-from optimize-format-call nil))))
[9464]	1970	(when (and
[9483]	1971	;; Must be able to split args
	1972	(< nargs (length args))
[9464]	1973	;; Don't deal with packages
	1974	(not (position #\: string :start ipos :end epos)))
	1975	(let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user))
	1976	(prev (and (< 0 start) (subseq string 0 start)))
[9483]	1977	(prev-args (subseq args 0 nargs))
[9464]	1978	(rest (and (< (1+ epos) (length string)) (subseq string (1+ epos))))
[9483]	1979	(rest-args (nthcdr nargs args))
	1980	(obj (pop rest-args))
[9464]	1981	(stream-var (gensym))
[9483]	1982	(body `(,@(and prev `((format ,stream-var ,prev ,@prev-args)))
[9464]	1983	(,func ,stream-var ,obj nil nil)
[9483]	1984	,(if rest `(format ,stream-var ,rest ,@rest-args) `nil))))
[9464]	1985	(cond ((null stream)
	1986	`(with-output-to-string (,stream-var)
	1987	(declare (type stream ,stream-var))
	1988	,@body))
	1989	((or (eq stream t) (nx-form-typep stream 'stream env))
	1990	`(let ((,stream-var ,(if (eq stream t) 'standard-output stream)))
	1991	(declare (type stream ,stream-var))
	1992	,@body))
	1993	(t
	1994	`(let ((,stream-var ,stream))
	1995	(if (or (null ,stream-var) (stringp ,stream-var))
[9617]	1996	(format-to-string ,stream-var ,string ,@args)
[9483]	1997	(let ((,stream-var
	1998	(if (eq ,stream-var t) standard-output ,stream-var)))
	1999	;; For the purposes of body, it's ok to assume stream-var
	2000	;; is a stream. method dispatch will signal any errors
	2001	;; at runtime if it's not true...
	2002	(declare (type stream ,stream-var))
[9464]	2003	,@body)))))))))
	2004
	2005
[6]	2006	(define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others)
	2007	(if (and sub0 (null others))
[1245]	2008	`(aref (the simple-bit-vector ,v) ,sub0)
[6]	2009	call))
	2010
	2011	(define-compiler-macro %sbitset (&environment env &whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)
	2012	(if (and newval-p (not newval-was-really-sub1) )
[1245]	2013	`(setf (aref (the simple-bit-vector ,v) ,sub0) ,newval)
[6]	2014	call))
	2015
	2016	(define-compiler-macro simple-base-string-p (thing)
[3228]	2017	`(= (the fixnum (typecode ,thing)) ,(nx-lookup-target-uvector-subtag :simple-string)))
[6]	2018
	2019	(define-compiler-macro simple-string-p (thing)
	2020	`(simple-base-string-p ,thing))
	2021
[7940]	2022	(define-compiler-macro stringp (thing)
	2023	`(base-string-p ,thing))
[6]	2024
[7940]	2025	(define-compiler-macro base-string-p (thing)
	2026	(let* ((gthing (gensym))
	2027	(gtype (gensym)))
	2028	`(let* ((,gthing ,thing)
[10008]	2029	(,gtype (typecode ,gthing)))
[7940]	2030	(declare (type (unsigned-byte 8) ,gtype))
	2031	(if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header))
	2032	(= (the (unsigned-byte 8)
	2033	(ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,gthing target::arrayH.flags-cell))))
	2034	,(nx-lookup-target-uvector-subtag :simple-string))
	2035	(= ,gtype ,(nx-lookup-target-uvector-subtag :simple-string))))))
	2036
	2037
[9578]	2038
[6]	2039	(defsetf %misc-ref %misc-set)
	2040
	2041	(define-compiler-macro lockp (lock)
[9038]	2042	(let* ((tag (nx-lookup-target-uvector-subtag :lock)))
[3228]	2043	`(eq ,tag (typecode ,lock))))
[6]	2044
[9578]	2045	(define-compiler-macro structurep (s)
	2046	(let* ((tag (nx-lookup-target-uvector-subtag :struct)))
	2047	`(eq ,tag (typecode ,s))))
	2048
[3228]	2049
[9389]	2050	(define-compiler-macro integerp (thing)
[3228]	2051	(let* ((typecode (gensym))
	2052	(fixnum-tag (arch::target-fixnum-tag (backend-target-arch target-backend)))
	2053	(bignum-tag (nx-lookup-target-uvector-subtag :bignum)))
	2054	`(let* ((,typecode (typecode ,thing)))
	2055	(declare (fixnum ,typecode))
[7940]	2056	(if (= ,typecode ,fixnum-tag)
	2057	t
	2058	(= ,typecode ,bignum-tag)))))
[8970]	2059
	2060	(define-compiler-macro realp (&whole call x)
	2061	(if (not (eq host-backend target-backend))
	2062	call
	2063	(let* ((typecode (gensym)))
	2064	`(let* ((,typecode (typecode ,x)))
	2065	(declare (type (unsigned-byte 8) ,typecode))
	2066	#+ppc32-target
	2067	(or (= ,typecode ppc32::tag-fixnum)
	2068	(and (>= ,typecode ppc32::min-numeric-subtag)
	2069	(<= ,typecode ppc32::max-real-subtag)))
	2070	#+ppc64-target
	2071	(if (<= ,typecode ppc64::subtag-double-float)
	2072	(logbitp (the (integer 0 #.ppc64::subtag-double-float) ,typecode)
	2073	(logior (ash 1 ppc64::tag-fixnum)
	2074	(ash 1 ppc64::subtag-single-float)
	2075	(ash 1 ppc64::subtag-double-float)
	2076	(ash 1 ppc64::subtag-bignum)
	2077	(ash 1 ppc64::subtag-ratio))))
	2078	#+x8664-target
	2079	(if (<= ,typecode x8664::subtag-double-float)
	2080	(logbitp (the (integer 0 #.x8664::subtag-double-float) ,typecode)
	2081	(logior (ash 1 x8664::tag-fixnum)
	2082	(ash 1 x8664::subtag-bignum)
	2083	(ash 1 x8664::tag-single-float)
	2084	(ash 1 x8664::subtag-double-float)
	2085	(ash 1 x8664::subtag-ratio))))))))
[9389]	2086
[388]	2087	(define-compiler-macro %composite-pointer-ref (size pointer offset)
	2088	(if (constantp size)
	2089	`(%inc-ptr ,pointer ,offset)
	2090	`(progn
	2091	,size
	2092	(%inc-ptr ,pointer ,offset))))
[6]	2093
[1140]	2094
	2095	(define-compiler-macro char= (&whole call ch &optional (other nil other-p) &rest others)
	2096	(if (null others)
	2097	(if other-p
	2098	`(eq (char-code ,ch) (char-code ,other))
	2099	`(progn (char-code ,ch) t))
[2248]	2100	(if (null (cdr others))
	2101	(let* ((third (car others))
[10008]	2102	(code (gensym))
	2103	(code2 (gensym))
	2104	(code3 (gensym)))
	2105	`(let* ((,code (char-code ,ch))
	2106	(,code2 (char-code ,other))
	2107	(,code3 (char-code ,third)))
	2108	(and (eq ,code ,code2)
	2109	(eq ,code2 ,code3))))
[2248]	2110	call)))
[1140]	2111
[3423]	2112	(define-compiler-macro char-equal (&whole call ch &optional (other nil other-p) &rest others)
	2113	(if (null others)
	2114	(if other-p
[9578]	2115	`(eq (%char-code-upcase (char-code ,ch)) (%char-code-upcase (char-code ,other)))
[3423]	2116	`(progn (char-code ,ch) t))
	2117	(if (null (cdr others))
	2118	(let* ((third (car others))
[10008]	2119	(code (gensym))
	2120	(code2 (gensym))
	2121	(code3 (gensym)))
	2122	`(let* ((,code (%char-code-upcase (char-code ,ch)))
	2123	(,code2 (%char-code-upcase (char-code ,other)))
	2124	(,code3 (%char-code-upcase (char-code ,third))))
	2125	(and (eq ,code ,code2)
	2126	(eq ,code ,code3))))
[3423]	2127	call)))
	2128
[1140]	2129	(define-compiler-macro char/= (&whole call ch &optional (other nil other-p) &rest others)
	2130	(if (null others)
	2131	(if other-p
	2132	`(not (eq (char-code ,ch) (char-code ,other)))
	2133	`(progn (char-code ,ch) t))
	2134	call))
	2135
	2136
	2137	(define-compiler-macro char< (&whole call ch &optional (other nil other-p) &rest others)
	2138	(if (null others)
	2139	(if other-p
	2140	`(< (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
	2141	`(progn (char-code ,ch) t))
[2248]	2142	(if (null (cdr others))
	2143	(let* ((third (car others))
[10008]	2144	(code (gensym))
	2145	(code2 (gensym))
	2146	(code3 (gensym)))
	2147	;; We have to evaluate all forms for side-effects.
	2148	;; Hopefully, there won't be any
	2149	`(let* ((,code (char-code ,ch))
	2150	(,code2 (char-code ,other))
	2151	(,code3 (char-code ,third)))
	2152	(declare (fixnum ,code ,code2 ,code3))
	2153	(and (< ,code ,code2)
	2154	(< ,code2 ,code3))))
[2248]	2155	call)))
[1140]	2156
	2157	(define-compiler-macro char<= (&whole call ch &optional (other nil other-p) &rest others)
	2158	(if (null others)
	2159	(if other-p
	2160	`(<= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
	2161	`(progn (char-code ,ch) t))
[2248]	2162	(if (null (cdr others))
	2163	(let* ((third (car others))
[10008]	2164	(code (gensym))
	2165	(code2 (gensym))
	2166	(code3 (gensym)))
	2167	`(let* ((,code (char-code ,ch))
	2168	(,code2 (char-code ,other))
	2169	(,code3 (char-code ,third)))
	2170	(declare (fixnum ,code ,code2 ,code3))
	2171	(and (<= ,code ,code2)
	2172	(<= ,code2 ,code3))))
[2248]	2173	call)))
[1140]	2174
	2175	(define-compiler-macro char> (&whole call ch &optional (other nil other-p) &rest others)
	2176	(if (null others)
	2177	(if other-p
	2178	`(> (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
	2179	`(progn (char-code ,ch) t))
[2248]	2180	(if (null (cdr others))
	2181	(let* ((third (car others))
[10008]	2182	(code (gensym))
	2183	(code2 (gensym))
	2184	(code3 (gensym)))
	2185	`(let* ((,code (char-code ,ch))
	2186	(,code2 (char-code ,other))
	2187	(,code3 (char-code ,third)))
[10348]	2188	(declare (fixnum ,code ,code2 ,code3))
[10008]	2189	(and (> ,code ,code2)
	2190	(> ,code2 ,code3))))
[2248]	2191	call)))
[1140]	2192
	2193	(define-compiler-macro char>= (&whole call ch &optional (other nil other-p) &rest others)
	2194	(if (null others)
	2195	(if other-p
	2196	`(>= (the fixnum (char-code ,ch)) (the fixnum (char-code ,other)))
	2197	`(progn (char-code ,ch) t))
[2248]	2198	(if (null (cdr others))
	2199	(let* ((third (car others))
[10008]	2200	(code (gensym))
	2201	(code2 (gensym))
	2202	(code3 (gensym)))
	2203	`(let* ((,code (char-code ,ch))
	2204	(,code2 (char-code ,other))
	2205	(,code3 (char-code ,third)))
	2206	(declare (fixnum ,code ,code2 ,code3))
	2207	(and (>= ,code ,code2)
	2208	(>= ,code2 ,code3))))
[2248]	2209	call)))
[1140]	2210
[6177]	2211	(define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env)
[9389]	2212
[3660]	2213	(cond ((and (typep other 'single-float)
	2214	(nx-form-typep number 'double-float env))
	2215	`(the single-float (%double-to-single ,number)))
	2216	((and (typep other 'double-float)
	2217	(nx-form-typep number 'single-float env))
	2218	`(the double-float (%single-to-double ,number)))
[6473]	2219	((and other-p (typep other 'single-float))
[6177]	2220	`(the single-float (%short-float ,number)))
	2221	((typep other 'double-float)
	2222	`(the double-float (%double-float ,number)))
[6473]	2223	((null other-p)
	2224	(let* ((temp (gensym)))
	2225	`(let* ((,temp ,number))
	2226	(if (typep ,temp 'double-float)
	2227	,temp
	2228	(the single-float (%short-float ,temp))))))
[3660]	2229	(t call)))
	2230
	2231	(define-compiler-macro coerce (&whole call thing type)
	2232	(if (quoted-form-p type)
	2233	(setq type (cadr type)))
	2234	(if (ignore-errors (subtypep type 'single-float))
	2235	`(float ,thing 0.0f0)
	2236	(if (ignore-errors (subtypep type 'double-float))
	2237	`(float ,thing 0.0d0)
	2238	call)))
	2239
[7624]	2240	(define-compiler-macro equal (&whole call x y &environment env)
	2241	(if (or (equal-iff-eql-p x env)
	2242	(equal-iff-eql-p y env))
	2243	`(eql ,x ,y)
	2244	call))
	2245
[8032]	2246	(define-compiler-macro instance-slots (&whole w instance)
	2247	(if (and (constantp instance)
	2248	(eql (typecode instance) (nx-lookup-target-uvector-subtag :instance)))
	2249	`(instance.slots ,instance)
[9350]	2250	(let* ((itemp (gensym))
	2251	(typecode (gensym)))
	2252	`(let* ((,itemp ,instance)
	2253	(,typecode (typecode ,itemp)))
	2254	(declare (type (unsigned-byte 8) ,typecode))
	2255	(if (eql ,typecode ,(nx-lookup-target-uvector-subtag :instance))
	2256	(instance.slots ,itemp)
	2257	(%non-standard-instance-slots ,itemp ,typecode))))))
[8032]	2258
[9350]	2259	(define-compiler-macro instance-class-wrapper (instance)
	2260	(let* ((itemp (gensym)))
	2261	`(let* ((,itemp ,instance))
	2262	(if (eql (the (unsigned-byte 8) (typecode ,itemp))
	2263	,(nx-lookup-target-uvector-subtag :instance))
	2264	(instance.class-wrapper ,itemp)
[9938]	2265	(non-standard-instance-class-wrapper ,itemp)))))
[9350]	2266
	2267	;; Instance must be a standard-instance.
	2268	(define-compiler-macro %class-of-instance (instance)
	2269	`(%wrapper-class (instance.class-wrapper ,instance)))
	2270
	2271	(define-compiler-macro standard-object-p (thing)
	2272	(let* ((temp (gensym))
	2273	(typecode (gensym)))
	2274	`(let* ((,temp ,thing)
	2275	(,typecode (typecode ,temp)))
	2276	(declare (type (unsigned-byte 8) ,typecode))
	2277	(if (= ,typecode ,(nx-lookup-target-uvector-subtag :instance))
	2278	(instance.class-wrapper ,temp)
	2279	(if (= ,typecode ,(nx-lookup-target-uvector-subtag :macptr))
	2280	(foreign-instance-class-wrapper ,temp))))))
	2281
[9578]	2282	(define-compiler-macro %class-ordinal (class &optional error)
	2283	(let* ((temp (gensym)))
	2284	`(let* ((,temp ,class))
	2285	(if (eql (the (unsigned-byte 8) (typecode ,temp))
	2286	,(nx-lookup-target-uvector-subtag :instance))
	2287	(instance.hash ,temp)
	2288	(funcall '%class-ordinal ,temp ,error)))))
	2289
	2290	(define-compiler-macro native-class-p (class)
	2291	(let* ((temp (gensym)))
	2292	`(let* ((,temp ,class))
	2293	(if (eql (the (unsigned-byte 8) (typecode ,temp))
	2294	,(nx-lookup-target-uvector-subtag :instance))
	2295	(< (the fixnum (instance.hash ,temp)) max-class-ordinal)))))
	2296
	2297
	2298
[8032]	2299	(define-compiler-macro unsigned-byte-p (x)
	2300	(if (typep (nx-unquote x) 'unsigned-byte)
	2301	t
	2302	(let* ((val (gensym)))
	2303	`(let* ((,val ,x))
	2304	(and (integerp ,val) (not (< ,val 0)))))))
	2305
[9578]	2306	(define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv &environment env)
	2307	(if (and (consp t1)
	2308	(consp (cdr t1))
	2309	(null (cddr t1))
	2310	(eq (car t1) 'type-of))
	2311	;; People really write code like this. I've seen it.
	2312	`(typep ,(cadr t1) ,t2 ,@(and rtenv `(,rtenv)))
	2313	(if (and (null rtenv) (quoted-form-p t2))
	2314	`(cell-csubtypep-2 ,t1 (load-time-value (register-type-cell ,t2)))
	2315	w)))
	2316
	2317
	2318	(define-compiler-macro string-equal (&whole w s1 s2 &rest keys)
	2319	(if (null keys)
	2320	`(%fixed-string-equal ,s1 ,s2)
	2321	(let* ((s1-arg (gensym))
	2322	(s2-arg (gensym)))
	2323	`(funcall
	2324	(lambda (,s1-arg ,s2-arg &key start1 end1 start2 end2)
	2325	(%bounded-string-equal ,s1-arg ,s2-arg start1 end1 start2 end2))
	2326	,s1 ,s2 ,@keys))))
	2327
	2328	;;; Try to use "package-references" to speed up package lookup when
	2329	;;; a package name is used as a constant argument to some functions.
	2330
	2331	(defun package-ref-form (arg)
	2332	(when (and arg (constantp arg) (typep (setq arg (nx-unquote arg))
	2333	'(or symbol string)))
	2334	`(load-time-value (register-package-ref ,(string arg)))))
	2335
	2336
[9938]	2337
[9578]	2338	(define-compiler-macro intern (&whole w string &optional package)
	2339	(let* ((ref (package-ref-form package)))
	2340	(if (or ref
	2341	(setq ref (and (consp package)
	2342	(eq (car package) 'find-package)
	2343	(consp (cdr package))
	2344	(null (cddr package))
	2345	(package-ref-form (cadr package)))))
	2346	`(%pkg-ref-intern ,string ,ref)
	2347	w)))
	2348
	2349	(define-compiler-macro find-symbol (&whole w string &optional package)
	2350	(let* ((ref (package-ref-form package)))
	2351	(if (or ref
	2352	(setq ref (and (consp package)
	2353	(eq (car package) 'find-package)
	2354	(consp (cdr package))
	2355	(null (cddr package))
	2356	(package-ref-form (cadr package)))))
	2357	`(%pkg-ref-find-symbol ,string ,ref)
	2358	w)))
	2359
	2360	(define-compiler-macro find-package (&whole w package)
	2361	(let* ((ref (package-ref-form package)))
	2362	(if ref
	2363	`(package-ref.pkg ,ref)
	2364	w)))
	2365
	2366	(define-compiler-macro pkg-arg (&whole w package &optional allow-deleted)
	2367	(let* ((ref (unless allow-deleted (package-ref-form package))))
	2368	(if ref
	2369	(let* ((r (gensym)))
	2370	`(let* ((,r ,ref))
	2371	(or (package-ref.pkg ,ref)
	2372	(%kernel-restart $xnopkg (package-ref.pkg ,r)))))
	2373	w)))
	2374
	2375
	2376	;;; In practice, things that're STREAMP are almost always
	2377	;;; BASIC-STREAMs or FUNDAMENTAL-STREAMs, but STREAMP is a generic
	2378	;;; function.
	2379	(define-compiler-macro streamp (arg)
	2380	(let* ((s (gensym)))
	2381	`(let* ((,s ,arg))
	2382	(or (typep ,s 'basic-stream)
	2383	(typep ,s 'fundamental-stream)
	2384	;; Don't recurse
	2385	(funcall 'streamp ,s)))))
	2386
	2387
	2388	(define-compiler-macro %char-code-case-fold (&whole w code vector &environment env)
	2389	(if (nx-open-code-in-line env)
	2390	(let* ((c (gensym))
	2391	(table (gensym)))
	2392	`(let* ((,c ,code)
	2393	(,table ,vector))
	2394	(declare (type (mod #x110000) ,c)
	2395	(type (simple-array (signed-byte 16) (*)) ,table))
	2396	(if (< ,c (length ,table))
	2397	(the fixnum (+ ,c (the (signed-byte 16)
	2398	(locally (declare (optimize (speed 3) (safety 0)))
	2399	(aref ,table ,c)))))
	2400	,c)))
	2401	w))
	2402
	2403	(define-compiler-macro %char-code-upcase (&whole w code &environment env)
	2404	(if (typep code '(mod #x110000))
	2405	(%char-code-upcase code)
	2406	`(%char-code-case-fold ,code lower-to-upper)))
	2407
	2408	(define-compiler-macro %char-code-downcase (&whole w code &environment env)
	2409	(if (typep code '(mod #x110000))
	2410	(%char-code-downcase code)
	2411	`(%char-code-case-fold ,code upper-to-lower)))
	2412
	2413	(define-compiler-macro char-upcase (char)
	2414	`(code-char (%char-code-upcase (char-code ,char))))
	2415
	2416
	2417	(define-compiler-macro register-istruct-cell (&whole w arg)
	2418	(if (and (quoted-form-p arg)
	2419	(cadr arg)
	2420	(typep (cadr arg) 'symbol))
	2421	`',(register-istruct-cell (cadr arg))
	2422	w))
	2423
	2424	(define-compiler-macro get-character-encoding (&whole w name)
	2425	(or (if (typep name 'keyword) (lookup-character-encoding name))
	2426	w))
[9938]	2427
	2428	(define-compiler-macro read-char (&optional stream (eof-error-p t) eof-value recursive-p)
	2429	`(read-char-internal ,stream ,eof-error-p (values ,eof-value ,recursive-p)))
	2430
[6]	2431	(provide "OPTIMIZERS")

Note: See TracBrowser for help on using the repository browser.

Download in other formats: