[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Gcl-commits] gcl omakefun.c debian/changelog cmpnew/gcl_cmpb...
|
From: |
Camm Maguire |
|
Subject: |
[Gcl-commits] gcl omakefun.c debian/changelog cmpnew/gcl_cmpb... |
|
Date: |
Sat, 17 Jun 2006 19:26:59 +0000 |
CVSROOT: /cvsroot/gcl
Module name: gcl
Changes by: Camm Maguire <camm> 06/06/17 19:26:58
Modified files:
o : makefun.c
debian : changelog
cmpnew : gcl_cmpbind.lsp gcl_cmpcall.lsp gcl_cmpenv.lsp
gcl_cmpeval.lsp gcl_cmpfun.lsp gcl_cmpif.lsp
gcl_cmpinline.lsp gcl_cmplam.lsp gcl_cmplet.lsp
gcl_cmploc.lsp gcl_cmpmulti.lsp gcl_cmpopt.lsp
gcl_cmpspecial.lsp gcl_cmptag.lsp
gcl_cmptop.lsp gcl_cmptype.lsp gcl_cmpvar.lsp
gcl_collectfn.lsp gcl_lfun_list.lsp
sys-proclaim.lisp
lsp : gcl_callhash.lsp gcl_predlib.lsp
pcl : gcl_pcl_impl_low.lisp
unixport : sys_ansi_gcl.c sys_gcl.c sys_mod_gcl.c
sys_pcl_gcl.c sys_pre_gcl.c
Log message:
eq uniq types, values return type autoproclamation support
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/gcl/o/makefun.c?cvsroot=gcl&r1=1.8&r2=1.9
http://cvs.savannah.gnu.org/viewcvs/gcl/debian/changelog?cvsroot=gcl&r1=1.1089&r2=1.1090
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpbind.lsp?cvsroot=gcl&r1=1.4&r2=1.5
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpcall.lsp?cvsroot=gcl&r1=1.14&r2=1.15
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpenv.lsp?cvsroot=gcl&r1=1.25&r2=1.26
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpeval.lsp?cvsroot=gcl&r1=1.55&r2=1.56
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpfun.lsp?cvsroot=gcl&r1=1.30&r2=1.31
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpif.lsp?cvsroot=gcl&r1=1.17&r2=1.18
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpinline.lsp?cvsroot=gcl&r1=1.41&r2=1.42
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmplam.lsp?cvsroot=gcl&r1=1.14&r2=1.15
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmplet.lsp?cvsroot=gcl&r1=1.26&r2=1.27
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmploc.lsp?cvsroot=gcl&r1=1.10&r2=1.11
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpmulti.lsp?cvsroot=gcl&r1=1.21&r2=1.22
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpopt.lsp?cvsroot=gcl&r1=1.33&r2=1.34
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpspecial.lsp?cvsroot=gcl&r1=1.13&r2=1.14
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmptag.lsp?cvsroot=gcl&r1=1.12&r2=1.13
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmptop.lsp?cvsroot=gcl&r1=1.37&r2=1.38
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmptype.lsp?cvsroot=gcl&r1=1.34&r2=1.35
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpvar.lsp?cvsroot=gcl&r1=1.17&r2=1.18
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_collectfn.lsp?cvsroot=gcl&r1=1.7&r2=1.8
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_lfun_list.lsp?cvsroot=gcl&r1=1.12&r2=1.13
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/sys-proclaim.lisp?cvsroot=gcl&r1=1.23&r2=1.24
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_callhash.lsp?cvsroot=gcl&r1=1.3&r2=1.4
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_predlib.lsp?cvsroot=gcl&r1=1.45&r2=1.46
http://cvs.savannah.gnu.org/viewcvs/gcl/pcl/gcl_pcl_impl_low.lisp?cvsroot=gcl&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_ansi_gcl.c?cvsroot=gcl&r1=1.16&r2=1.17
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_gcl.c?cvsroot=gcl&r1=1.24&r2=1.25
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_mod_gcl.c?cvsroot=gcl&r1=1.11&r2=1.12
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_pcl_gcl.c?cvsroot=gcl&r1=1.15&r2=1.16
http://cvs.savannah.gnu.org/viewcvs/gcl/unixport/sys_pre_gcl.c?cvsroot=gcl&r1=1.11&r2=1.12
Patches:
Index: o/makefun.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/makefun.c,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -b -r1.8 -r1.9
--- o/makefun.c 6 Nov 2005 18:07:37 -0000 1.8
+++ o/makefun.c 17 Jun 2006 19:26:57 -0000 1.9
@@ -157,7 +157,8 @@
break;
}
else
- ta=MMcons(sLA,Cnil);
+/* ta=MMcons(sLA,Cnil); */
+ ta=sLA;
putprop(sym,ta,sSproclaimed_return_type);
if (oneval)
putprop(sym,Ct,sSproclaimed_function);
Index: debian/changelog
===================================================================
RCS file: /cvsroot/gcl/gcl/debian/changelog,v
retrieving revision 1.1089
retrieving revision 1.1090
diff -u -b -r1.1089 -r1.1090
--- debian/changelog 9 Jun 2006 20:50:57 -0000 1.1089
+++ debian/changelog 17 Jun 2006 19:26:58 -0000 1.1090
@@ -180,8 +180,9 @@
funcallable (in preparation for automatic state/mutual recursion
conversion),speed up proper-list type-or, give fdefinition a lisp
definition to set up the prototype (removes a number of * returns)
+ * eq uniq types, values return type autoproclamation support
- -- Camm Maguire <address@hidden> Fri, 9 Jun 2006 20:50:39 +0000
+ -- Camm Maguire <address@hidden> Sat, 17 Jun 2006 19:26:49 +0000
gclcvs (2.7.0-53) unstable; urgency=low
Index: cmpnew/gcl_cmpbind.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpbind.lsp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -b -r1.4 -r1.5
--- cmpnew/gcl_cmpbind.lsp 8 Jul 2005 06:02:47 -0000 1.4
+++ cmpnew/gcl_cmpbind.lsp 17 Jun 2006 19:26:58 -0000 1.5
@@ -48,22 +48,22 @@
(wt-vs (var-ref var))
(wt ";"))
(t (wfs-error))))
- (INTEGER
+ (t
+ (cond ((eq (var-kind var) #tinteger)
(wt-nl "SETQ_IO(V" (var-loc var)","
"V" (var-loc var)"alloc,")
(wt "(") (wt-vs (var-ref var)) (wt "),")
(wt (bignum-expansion-storage) ");"))
(t
(wt-nl "V" (var-loc var) "=")
- (case (var-kind var)
- (OBJECT)
- (FIXNUM (wt "fix"))
- (CHARACTER (wt "char_code"))
- (LONG-FLOAT (wt "lf"))
- (SHORT-FLOAT (wt "sf"))
- (t (baboon)))
- (wt "(") (wt-vs (var-ref var)) (wt ");")))
- )
+ (cond ;FIXME
+ ((eq (var-kind var) 'OBJECT))
+ ((eq (var-kind var) #tfixnum) (wt "fix"))
+ ((eq (var-kind var) #tcharacter) (wt "char_code"))
+ ((eq (var-kind var) #tlong-float) (wt "lf"))
+ ((eq (var-kind var) #tshort-float) (wt "sf"))
+ ((baboon)))
+ (wt "(") (wt-vs (var-ref var)) (wt ");"))))))
(defun c2bind-loc (var loc)
(case (var-kind var)
@@ -82,7 +82,8 @@
(DOWN
(wt-nl "base0[" (var-loc var) "]=" loc ";"))
- (INTEGER
+ (t
+ (cond ((eq (var-kind var) #tinteger)
(let ((*inline-blocks* 0) (*restore-avma* *restore-avma*))
(save-avma '(nil integer))
(wt-nl "V" (var-loc var) "= ")
@@ -94,7 +95,7 @@
(let ((wtf (cdr (assoc (var-kind var) +wt-loc-alist+))))
(unless wtf (baboon))
(funcall wtf loc))
- (wt ";"))))
+ (wt ";"))))))
(defun c2bind-init (var init)
(case (var-kind var)
Index: cmpnew/gcl_cmpcall.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpcall.lsp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -b -r1.14 -r1.15
--- cmpnew/gcl_cmpcall.lsp 16 May 2006 21:46:16 -0000 1.14
+++ cmpnew/gcl_cmpcall.lsp 17 Jun 2006 19:26:58 -0000 1.15
@@ -32,13 +32,14 @@
(defun fast-link-proclaimed-type-p (fname &optional args)
(and
(symbolp fname)
- (and (< (the fixnum(length args)) 64)
+ (and (< (length args) 64)
(or (and (get fname 'fixed-args)
(listp args))
(and
(get fname 'proclaimed-function)
- (link-arg-p (get fname 'proclaimed-return-type))
- (dolist (v (get fname 'proclaimed-arg-types) t)
+ (let ((v (get-return-type fname)))
+ (and v (type>= t v) (link-arg-p v)))
+ (dolist (v (get-arg-types fname) t)
(or (eq v '*)(link-arg-p v) (return nil))))))))
(si::putprop 'funcall 'c2funcall-aux 'wholec2)
@@ -154,7 +155,7 @@
; (eq *value-to-go* 'trash)
; (and (consp *value-to-go*)
; (eq (car *value-to-go*) 'var))
- (and info (equal (info-type info) '(values t)))))
+ (and info (type>= t (info-type info)))))
(c2funcall-sfun form args info)
(return-from c2funcall nil)))
(unless loc
@@ -300,7 +301,7 @@
( t; *Fast-link-compiling*
(cond ((and
(listp args)
- (< (the fixnum (length args)) 10)
+ (< (length args) 10)
(or
*ifuncall*
(get fname 'ifuncall))
@@ -345,7 +346,7 @@
(leng (and (listp args) (length args))))
(setq argtypes
(cond ((get fname 'proclaimed-function)
- (get fname 'proclaimed-arg-types))
+ (get-arg-types fname))
((setq tem (get fname ' fixed-args))
(cond ((si:fixnump tem)
(or (equal leng tem)
@@ -395,14 +396,12 @@
(wt-inline-loc link-string l)
(wt ")")))))
(push (list fname argtypes
- (or (get fname 'proclaimed-return-type)
- t)
+ (let ((z (get-return-type fname))) (cond ((eq z
#tboolean)) ((not z)) (z)))
(flags side-effect-p allocates-new-storage)
(or link link-string) 'link-call)
*inline-functions*))
(setq link-info (list fname (format nil "LI~d" n)
- (or (get fname 'proclaimed-return-type)
- t)
+ (let ((z (get-return-type fname))) (cond
((eq z #tboolean)) ((not z)) (z)))
argtypes)))))
(t
(check-fname-args fname args)
Index: cmpnew/gcl_cmpenv.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpenv.lsp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -b -r1.25 -r1.26
--- cmpnew/gcl_cmpenv.lsp 5 Jun 2006 22:23:44 -0000 1.25
+++ cmpnew/gcl_cmpenv.lsp 17 Jun 2006 19:26:58 -0000 1.26
@@ -56,10 +56,8 @@
(setq *inline-functions* nil)
(setq *inline-blocks* 0)
(setq *notinline* nil)
- (setq *portable-source* nil)
- (clrhash *norm-tp-hash*)
- (clrhash *and-tp-hash*)
- (clrhash *or-tp-hash*))
+ (setq *portable-source* nil))
+
(defvar *next-cvar* 0)
(defvar *next-cmacro* 0)
@@ -232,18 +230,18 @@
((and (symbolp fname)
(listp decl) (listp (cdr decl)))
(cond ((or (null decl)(eq (car decl) '*)) (setq arg-types '(*)))
- (t (setq arg-types (function-arg-types (car decl)))
- ))
+ (t (setq arg-types (function-arg-types (car decl)))))
(setq return-types (function-return-type (cdr decl)))
(when (and (consp return-types) (consp (cdr return-types)))
(setq return-types (cons 'values return-types)))
(cond ((and (consp return-types) ; ie not nil
- (endp (cdr return-types))
- (not (eq (car return-types) '*)))
+ (endp (cdr return-types)))
(setq return-types
;; varargs must return type t currently.
- (if (member '* (and (consp arg-types) arg-types)) t
- (car return-types))))
+ (if (and (type>= t (cmp-norm-tp (car return-types)))
+ (member '* (and (consp arg-types) arg-types)))
+ t (car return-types))
+ procl (unless (eq '* return-types) procl)))
(t (setq procl nil)))
(cond ((and (listp arg-types)
(< (length arg-types) call-arguments-limit)))
@@ -279,15 +277,18 @@
(t (warn "The function name ~s is not a symbol." fname))))
(defun get-arg-types (fname &aux x)
+ (mapcar 'cmp-norm-tp
(if (setq x (assoc fname *function-declarations*))
(cadr x)
- (get fname 'proclaimed-arg-types)))
+ (get fname 'proclaimed-arg-types))))
(defun get-return-type (fname)
+ (cmp-norm-tp
(when (symbolp fname)
(let* ((x (assoc fname *function-declarations*))
(type1 (if x (caddr x) (get fname 'proclaimed-return-type)))
- (type (if (get fname 'predicate) 'boolean
+ ; (type1 (if (equal '(*)
type1) '* type1))
+ (type (if (get fname 'predicate) #tboolean
(get fname 'return-type))))
(cond (type1
(cond (type
@@ -297,7 +298,7 @@
"The return type of ~s was badly declared."
fname))))
(t type1)))
- (t type)))))
+ (t type))))))
(defun get-local-arg-types (fun &aux x)
(if (setq x (assoc fun *function-declarations*))
@@ -520,7 +521,7 @@
(push (cons var 'dynamic-extent) ts)))
(otherwise
(let ((type (cmp-norm-tp stype)))
- (if type
+ (if (not (eq type '*))
(dolist** (var (cdr decl))
(cmpck (not (symbolp var))
"The type declaration ~s
contains a non-symbol ~s."
Index: cmpnew/gcl_cmpeval.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpeval.lsp,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -b -r1.55 -r1.56
--- cmpnew/gcl_cmpeval.lsp 5 Jun 2006 22:02:45 -0000 1.55
+++ cmpnew/gcl_cmpeval.lsp 17 Jun 2006 19:26:58 -0000 1.56
@@ -29,9 +29,6 @@
(in-package 'compiler)
-(import 'si::+array-types+ 'compiler)
-(import 'si::+aet-type-object+ 'compiler)
-
(si:putprop 'progn 'c1progn 'c1special)
(si:putprop 'progn 'c2progn 'c2)
@@ -144,7 +141,7 @@
(defun fix-opt (opt)
(let ((a (cddr opt)))
- (unless (typep (car a ) 'fixnum)
+ (unless (typep (car a ) #tfixnum)
(if *compiler-in-use*
(cmpwarn "Obsolete optimization: use fix-opt ~s" opt))
@@ -204,7 +201,7 @@
(let* ((be (get f 'type-propagator))
(ba (and be (si::dt-apply be (cons f (mapcar 'coerce-to-one-value
args))))));FIXME
(when ba
- (return-from result-type-from-args ba)))
+ (return-from result-type-from-args (cmp-norm-tp ba))))
(dolist (v '(inline-always inline-unsafe))
(let* ((w (get f v)))
(if (and w (symbolp (caar w)) (flag-p (third (car w)) itf))
@@ -220,7 +217,7 @@
(or (eq (car a) (car b))
(type>= (car b) (car a))))
(return nil))))
- (return-from result-type-from-args (second w)))))))))
+ (return-from result-type-from-args (cmp-norm-tp (second
w))))))))))
;; omitting a flag means it is set to nil.
@@ -414,7 +411,7 @@
(let* ((non (inlinable-fn (cadr form))) ;;FIXME, we need to centralize
things like this
(n (if non (cadr form) (gensym))) (l (gensym)))
`(let (,@(unless non `((,n ,(cadr form)))) (,l ,(caddr form)))
- (if (typep ,n 'seqind);;FIX typep inference to branch types outside
of +type-alist+
+ (if (typep ,n ',#tseqind);;FIX typep inference to branch types
outside of +type-alist+
(cmp-nthcdr ,n ,l)
(cmp-nthcdr ,n ,l))))
form))
@@ -441,14 +438,14 @@
(declare (ignore env))
(let ((x (gensym)) (i (gensym)) (s (gensym)))
`(let ((,s ,(cadr form)))
- (if (typep ,s 'vector)
+ (if (listp ,s)
+ (let (,x)
+ (do ((,s ,s (cdr ,s))) ((endp ,s) ,x)
+ (setq ,x (cons (car ,s) ,x))))
(let ((,x (make-array (length ,s) :element-type
(cmp-array-element-type ,s))))
(do ((,i 0 (1+ ,i))) ((= ,i (length ,s)) ,x)
(declare (seqind ,i))
- (setf (aref ,x (1- (- (length ,s) ,i))) (aref ,s ,i))))
- (let (,x)
- (do ((,s ,s (cdr ,s))) ((endp ,s) ,x)
- (setq ,x (cons (car ,s) ,x))))))))
+ (setf (aref ,x (1- (- (length ,s) ,i))) (aref ,s ,i))))))))
(si::putprop 'reverse (function reverse-expander) 'si::compiler-macro-prop)
(defmacro with-var-form-type ((v f tp) &rest body)
@@ -462,9 +459,9 @@
(declare (ignore env))
(let ((i (gensym)) (s (gensym)))
(with-var-form-type
- (s (cadr form) 'sequence)
+ (s (cadr form) #tsequence)
(with-var-form-type
- (i (caddr form) 'seqind)
+ (i (caddr form) #tseqind)
`(if (listp ,s) (nth ,i ,s) (aref ,s ,i))))))
(si::putprop 'elt (function elt-expander) 'si::compiler-macro-prop)
@@ -472,7 +469,7 @@
(defun length-expander (form env)
(declare (ignore env))
(let ((i (gensym)) (s (gensym)))
- (with-var-form-type (s (cadr form) 'sequence)
+ (with-var-form-type (s (cadr form) #tsequence)
`(if (listp ,s)
(do ((,i 0 (1+ ,i)) (,s ,s (cdr ,s))) ((endp ,s) ,i)
(declare (seqind ,i)))
@@ -503,7 +500,7 @@
,(when list `(do ((,fi 0 (1+ ,fi)) (,l ,l (cdr ,l))) ((= ,fi ,ll))
(declare (seqind ,fi))
(setf (aref ,a ,fi) ,l)))
- (let* ((,ii (make-array 1024 :element-type 'non-negative-fixnum
:adjustable t))
+ (let* ((,ii (make-array 1024 :element-type ',#tnon-negative-fixnum
:adjustable t))
(,s 2))
(declare (seqind ,s) ((vector seqind) ,ii));FIXME (adjust-array
(setf (aref ,ii 0) 0 (aref ,ii 1) ,ll)
@@ -551,13 +548,13 @@
form
(let ((seq (gensym)))
`(let ((,seq ,(cadr form)))
- (if (typep ,seq 'vector)
- (let ((,seq ,seq))
- (declare (vector ,seq))
- ,(qsl-fun seq (caddr form) (if (cdddr form) (fifth form)
''identity) nil))
+ (if (listp ,seq)
(let ((,seq ,seq))
(declare (list ,seq))
- ,(qsl-fun seq (caddr form) (if (cdddr form) (fifth form)
''identity) t)))))))
+ ,(qsl-fun seq (caddr form) (if (cdddr form) (fifth form)
''identity) t))
+ (let ((,seq ,seq))
+ (declare (vector ,seq))
+ ,(qsl-fun seq (caddr form) (if (cdddr form) (fifth form)
''identity) nil)))))))
(si::putprop 'sort 'qsort-expander 'si::compiler-macro-prop)
(defun mheap (a r b key p)
@@ -580,7 +577,7 @@
,k (ash ,j 1))
(return-from ,block))))))))
-(defconstant +hash-index-type+ (car (resolve-type `(or (integer -1 -1)
seqind))))
+(defconstant +hash-index-type+ #t(or (integer -1 -1) seqind))
(defun sort-expander (form env)
(declare (ignore env))
@@ -722,7 +719,7 @@
(r `(,@special-keys ,@r)))
(let ((form (apply 'do-list-search test list r)))
(if (member :item special-keys)
- `(if (is-eq-test-item-list ,test ,item ,list); (and (eq ,test 'eql)
(eql-is-eq ,item ,test ,list))
+ `(if (is-eq-test-item-list ,test ,item ,list ',r); (and (eq ,test
'eql) (eql-is-eq ,item ,test ,list))
,(apply 'do-list-search ''eq list r)
,form)
form))))
@@ -836,21 +833,23 @@
(declare (ignore test not))
(let* ((newseq (cmp-eval newseq))
(ns newseq)
- (newseq (and newseqp (cond ((not newseq) :nil) ((type>= 'list newseq)
:list) ((type>= 'vector newseq) :vector))))
+ (newseq (and newseqp (cond ((not newseq) :nil)
+ ((type>= #tlist (cmp-norm-tp newseq)) :list)
+ ((type>= #tvector (cmp-norm-tp newseq))
:vector))))
(gs (mapcar (lambda (x) (list (gensym) x)) vars))
(l (gensym))
(lf (mapcar (lambda (x) `(length ,x)) vars))
- (lf (if destp `((if (typep ,dest 'vector) (array-dimension ,dest 0)
(length ,dest)) ,@lf) lf))
+ (lf (if destp `((if (listp ,dest) (length ,dest) (array-dimension
,dest 0)) ,@lf) lf))
(lf (if end `(,end ,@lf) lf))
(lf (if (> (length lf) 1) (cons 'min lf) (car lf)))
(lf (if (or pos start end (eq newseq :vector)) lf
- `(if (or ,@(when destp `((typep ,dest 'vector)))
- ,@(mapcar (lambda (x) `(typep ,x 'vector)) vars))
,lf -1)))
+ `(if (and ,@(when destp `((listp ,dest)))
+ ,@(mapcar (lambda (x) `(listp ,x)) vars)) -1
,lf)))
(lf `((,l ,lf)))
(i (gensym))
- (tf (mapcar (lambda (x) `(if (typep ,(cadr x) 'vector) (aref ,(cadr x)
,i) (car ,(car x)))) gs))
+ (tf (mapcar (lambda (x) `(if (listp ,(cadr x)) (car ,(car x)) (aref
,(cadr x) ,i))) gs))
(tf (if ret (mapcar (lambda (x) `(funcall ,ret ,x)) tf) tf))
(tf (if k1 (mapcar (lambda (x) `(funcall ,k1 ,x)) tf) tf))
(tf (if keyp (mapcar (lambda (x) `(funcall ,key ,x)) tf) tf))
@@ -873,24 +872,24 @@
(tf (if (and sum (not ivp)) (if (= (length vars) 1) `(if ,fv ,tf
,first) (baboon)) tf))
(inf (mapcar (lambda (x)
- `(,(car x) ,(cadr x) (if (typep ,(cadr x) 'vector)
,(car x) (cdr ,(car x))))) gs))
+ `(,(car x) ,(cadr x) (if (listp ,(cadr x)) (cdr ,(car
x)) ,(car x)))) gs))
(inf `((,i 0 ,@(if (or pos start end (eq newseq :vector)) `((+ ,i 1))
`((if (>= ,l 0) (+ ,i 1) ,i)))) ,@inf))
(lf (if (eq newseq :vector)
`(,@lf (,out (make-array ,l
:fill-pointer ,l
- :element-type
',(upgraded-array-element-type (si::sequence-type-element-type ns))))) lf))
+ :element-type ',(cmp-norm-tp
(upgraded-array-element-type (si::sequence-type-element-type ns)))))) lf))
; :element-type (cmp-array-element-type
,@vars)))) lf))
(lf (if (or destp (eq newseq :list))
- `(,@lf (,p (unless (typep ,dest 'vector) ,dest))) lf))
+ `(,@lf (,p (when (listp ,dest) ,dest))) lf))
(lf (if sum `(,@lf (,fv ,ivp) (,sv ,iv)) lf))
(lf (if somep `(,@lf (,sm ,(not some))) lf))
(lf (if count `(,@lf (,cv 0)) lf))
(lf (if (eq newseq :list ) `(,@lf ,lh) lf))
(inf (if (or destp (eq newseq :list))
- `((,p ,p (if (or (typep ,dest 'vector) ,(eq newseq :list)) ,p
(cdr ,p))) ,@inf) inf))
- (tf (cond (destp `(cond ((typep ,dest 'vector) (setf (aref ,dest ,i)
,tf) nil)
- ((setf (car ,p) ,tf) nil)))
+ `((,p ,p (if (and (listp ,dest) ,(not (eq newseq :list)))
(cdr ,p) ,p)) ,@inf) inf))
+ (tf (cond (destp `(cond ((listp ,dest) (setf (car ,p) ,tf) nil)
+ ((setf (aref ,dest ,i) ,tf) nil)))
((eq newseq :list) `(and (setq ,p (let ((,tmp (cons ,tf
nil)))
(if ,p (cdr (rplacd ,p
,tmp))
(setq ,lh ,tmp))))
nil))
@@ -906,7 +905,7 @@
(ef (if (or pos start end (eq newseq :vector)) ef `(and (>= ,l 0)
,ef)))
(ef `(if ,ef t
,@(if (or pos start end (eq newseq :vector)) `(,tf)
- `(,(reduce (lambda (x y) `(if (and (not (typep ,(cadr x)
'vector)) (endp ,(car x))) t ,y))
+ `(,(reduce (lambda (x y) `(if (and (listp ,(cadr x)) (endp
,(car x))) t ,y))
`(,@(when destp `((,p ,dest))) ,@gs)
:initial-value tf :from-end t)))))
(rf (cond (destp dest)
((eq newseq :nil) nil)
@@ -921,8 +920,9 @@
`(let* ,lf
,@(when count `((declare (seqind ,cv))))
,@(when destp
- `((when (and (typep ,dest 'vector) (array-has-fill-pointer-p ,dest))
- (setf (fill-pointer ,dest) ,l))))
+ `((unless (listp ,dest)
+ (when (array-has-fill-pointer-p ,dest)
+ (setf (fill-pointer ,dest) ,l)))))
(do ,inf (,ef ,rf)(declare (seqind ,i))))))
(defun possible-eq-sequence-search (item seq special-keys &rest r
@@ -933,7 +933,7 @@
(r `(,@special-keys ,@r)))
(let ((form (apply 'do-sequence-search test (list seq) r)))
(if (member :item special-keys)
- `(if (is-eq-test-item-list ,test ,item ,seq); FIXME
+ `(if (is-eq-test-item-list ,test ,item ,seq ',r); FIXME
,(apply 'do-sequence-search ''eq (list seq) r)
,form)
form))))
@@ -969,12 +969,12 @@
(form (apply 'possible-eq-sequence-search (car r) (cadr r) specials
`(,@overrides ,@(cddr r)))))
`(let (,@syms)
,@(if (constantp (cadr r)) (list form)
- `((if (typep ,(cadr r) 'vector)
+ `((if (listp ,(cadr r))
(let ((,(cadr r) ,(cadr r)))
- (declare (vector ,(cadr r)))
+ (declare (list ,(cadr r)))
,form)
(let ((,(cadr r) ,(cadr r)))
- (declare (list ,(cadr r)))
+ (declare (vector ,(cadr r)))
,form))))))))
(si::putprop 'position (macro-function 'seq-compiler-macro)
'si::compiler-macro-prop)
(si::putprop 'position-if (macro-function 'seq-compiler-macro)
'si::compiler-macro-prop)
@@ -1006,7 +1006,7 @@
(defmacro map-into-compiler-macro (&whole w &rest args)
(if (or (< (length args) 3) (and (eq (car w) 'map) (or (not (constantp (car
args)))
- (not (type>= 'sequence
(cmp-eval (car args)))))))
+ (not (type>=
#tsequence (cmp-norm-tp (cmp-eval (car args))))))))
w
(let* ((syms (reduce (lambda (&rest r)
(when r
@@ -1035,12 +1035,12 @@
(form (apply 'do-sequence-search (car r) (list (cadr r)) `( :sum t
,@(substitute :iv :initial-value (cddr args))))))
`(let ,syms
,@(if (constantp (cadr r)) (list form)
- `((if (typep ,(cadr r) 'vector)
+ `((if (listp ,(cadr r))
(let ((,(cadr r) ,(cadr r)))
- (declare (vector ,(cadr r)))
+ (declare (list ,(cadr r)))
,form)
(let ((,(cadr r) ,(cadr r)))
- (declare (list ,(cadr r)))
+ (declare (vector ,(cadr r)))
,form))))))))
(si::putprop 'reduce (macro-function 'compiler::reduce-compiler-macro)
'si::compiler-macro-prop)
@@ -1181,8 +1181,8 @@
(let ((fname (or (cdr (assoc fname +cmp-fn-alist+))
fname)))
(list (cons fname
(let* ((at (get fname
'proclaimed-arg-types))
- (rt (get fname
'proclaimed-return-type))
- (rt (if (equal '(*) rt) '* rt)))
+ (rt (get fname
'proclaimed-return-type)))
+; (rt (if (equal '(*) rt) '* rt)))
(when (or at rt) (list at rt))))))
nil)))
((and (setq fd (get fname 'si::structure-access))
@@ -1217,7 +1217,8 @@
(and (consp (car args)) (eq (caar args)
'function) (cadar args)))
(otherwise fname)))))
(when return-type
- (setf (info-type info) (if (or (eq return-type '*) (equal
return-type '(*))) '* return-type))
+; (setf (info-type info) (if (or (eq return-type '*) (equal
return-type '(*))) '* return-type))
+ (setf (info-type info) return-type)
; (if (or (eq return-type '*) (equal return-type '(*)))
; (setf return-type nil)
; (setf (info-type info) return-type))
@@ -1248,7 +1249,7 @@
;; some functions can have result type deduced from
;; arg types.
(let ((tem (result-type-from-args fname
- (mapcar #'(lambda (x) (info-type
(cadr x)))
+ (mapcar (lambda (x)
(coerce-to-one-value (info-type (cadr x))))
forms))))
(when tem
(setq tem (type-and tem (info-type info)))
@@ -1401,8 +1402,8 @@
)
(setf (info-type info) (if (and (eq name 'si::s-data) (= index 2))
;;FIXME -- this belongs somewhere else. CM
20050106
- '(vector unsigned-char)
- (type-filter (nth aet-type +array-types+))))
+ #t(vector unsigned-char)
+ (type-filter (nth aet-type +cmp-array-types+))))
(list 'structure-ref info
(c1expr* form info)
(add-symbol name)
@@ -1415,7 +1416,7 @@
(index (caddr form)))
(cond (sd
(let* ((aet-type (aref (si::s-data-raw sd) index))
- (type (nth aet-type +array-types+)))
+ (type (nth aet-type +cmp-array-types+)))
(cond ((eq (inline-type (type-filter type)) 'inline)
(or (= aet-type +aet-type-object+) (error "bad type ~a"
type))))
(setf (info-type (car arg)) (type-filter type))
@@ -1437,7 +1438,7 @@
(defun c2structure-ref (form name-vv index sd
&aux (*vs* *vs*) (*inline-blocks* 0))
(let ((loc (car (inline-args (list form) '(t))))
- (type (nth (aref (si::s-data-raw sd) index) +array-types+)))
+ (type (nth (aref (si::s-data-raw sd) index) +cmp-array-types+)))
(unwind-exit
(list (inline-type (type-filter type))
(flags) 'my-call
@@ -1451,7 +1452,7 @@
(let* ((raw (si::s-data-raw sd))
(spos (si::s-data-slot-position sd)))
(if *safe-compile* (wfs-error)
- (wt "STREF(" (aet-c-type (nth (aref raw ind) +array-types+) )
+ (wt "STREF(" (aet-c-type (nth (aref raw ind) +cmp-array-types+) )
"," loc "," (aref spos ind) ")"))))
@@ -1489,7 +1490,7 @@
&aux locs (*vs* *vs*) (*inline-blocks* 0))
name-vv
(let* ((raw (si::s-data-raw sd))
- (type (nth (aref raw ind) +array-types+))
+ (type (nth (aref raw ind) +cmp-array-types+))
(spos (si::s-data-slot-position sd))
(tftype (type-filter type))
ix iy)
@@ -1508,6 +1509,8 @@
(close-inline-blocks)
))
+(defun sv-wrap (x) `(symbol-value ',x))
+
(defun c1constant-value (val always-p)
(cond
((eq val nil) (c1nil))
@@ -1521,23 +1524,18 @@
(list 'CHARACTER-VALUE (add-object val) (char-code val))))
((typep val 'long-float)
;; We can't read in long-floats which are too big:
- (let (tem x)
- (unless (setq tem (cadr (assoc val *objects*)))
- (cond ((or ;FIXME this is really grotesque
- (and (= val (symbol-value '+inf)) (let ((l (make-list 3)))
(setf (car l) 'si::|#,| (cadr l) 'symbol-value (caddr l) ''+inf) (c1expr l)))
- (and (= val (symbol-value '-inf)) (let ((l (make-list 3)))
(setf (car l) 'si::|#,| (cadr l) 'symbol-value (caddr l) ''-inf) (c1expr l)))
- (and (not (isfinite val)) (let ((l (make-list 3))) (setf (car
l) 'si::|#,| (cadr l) 'symbol-value (caddr l) ''nan) (c1expr l)))
- (and
- (> (setq x (abs val)) (/ most-positive-long-float 2))
- (c1expr `(si::|#,| * ,(/ val most-positive-long-float)
- most-positive-long-float)))
- (and
- (< x (* least-positive-long-float 1.0d20))
- (c1expr `(si::|#,| * ,(/ val least-positive-long-float)
- least-positive-long-float))))
- (push (list val (setq tem *next-vv*)) *objects*))))
- (list 'LOCATION (make-info :type `(long-float ,val ,val))
- (list 'LONG-FLOAT-VALUE (or tem (add-object val)) val))))
+ (let* (sc
+ (vv
+ (cond ((= val +inf) (add-object (cons 'si::|#,| `(symbol-value
','+inf))));This cannot be a constant list
+ ((= val -inf) (add-object (cons 'si::|#,| `(symbol-value
','-inf))))
+ ((not (isfinite val)) (add-object (cons 'si::|#,|
`(symbol-value ','nan))))
+ ((> (abs val) (/ most-positive-long-float 2))
+ (add-object (cons 'si::|#,| `(* ,(/ val
most-positive-long-float) most-positive-long-float))))
+ ((< (abs val) (* least-positive-long-float 1.0d20))
+ (add-object (cons `si::|#,| `(* ,(/ val
least-positive-long-float) least-positive-long-float))))
+ ((setq sc t) (add-object val)))))
+ `(location ,(make-info :type (if (isfinite val) `(long-float ,val ,val)
'long-float))
+ ,(if sc `(long-float-value ,vv ,val) `(vv ,vv)))))
((typep val 'short-float)
(list 'LOCATION (make-info :type `(short-float ,val ,val))
(list 'SHORT-FLOAT-VALUE (add-object val) val)))
Index: cmpnew/gcl_cmpfun.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpfun.lsp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -b -r1.30 -r1.31
--- cmpnew/gcl_cmpfun.lsp 5 Jun 2006 22:02:45 -0000 1.30
+++ cmpnew/gcl_cmpfun.lsp 17 Jun 2006 19:26:58 -0000 1.31
@@ -296,16 +296,16 @@
(defmacro eq-subtp (x y) ;FIXME axe mult values
(let ((s (gensym)))
`(let ((,s (type>= ,y ,x)))
- (values ,s (or ,s (type>= `(not ,,y) x))))))
+ (values ,s (or ,s (type>= (cmp-norm-tp `(not ,,y)) x))))))
(defun eql-is-eq-tp (x)
- (eq-subtp x 'eql-is-eq-tp))
+ (eq-subtp x #teql-is-eq-tp))
(defun equal-is-eq-tp (x)
- (eq-subtp x 'equal-is-eq-tp))
+ (eq-subtp x #tequal-is-eq-tp))
(defun equalp-is-eq-tp (x)
- (eq-subtp x 'equalp-is-eq-tp))
+ (eq-subtp x #tequalp-is-eq-tp))
(defun do-eq-et-al (fn args)
(let* ((tf (cadr (test-to-tf fn)))
@@ -385,7 +385,7 @@
(si::putprop l 'do-num-relations 'c1g))
(dolist (l `(eq eql equal equalp > >= < <= = /= length ;FIXME get a good list
here
- ,@(mapcar (lambda (x) (cdr x)) (remove-if-not (lambda (x)
(symbolp (cdr x))) +type-alist+))))
+ ,@(mapcar (lambda (x) (cdr x)) (remove-if-not (lambda (x)
(symbolp (cdr x))) +cmp-type-alist+))))
(si::putprop l t 'c1no-side-effects))
;;bound type comparisons
@@ -416,8 +416,8 @@
((member test `(equal ,#'equal)) '(equal-is-eq equal-is-eq-tp))
((member test `(equalp ,#'equalp)) '(equalp-is-eq equalp-is-eq-tp)))))
-(defun is-eq-test-item-list (test item list)
- (declare (ignore list))
+(defun is-eq-test-item-list (test item list rest)
+ (declare (ignore list rest))
(let ((tf (car (test-to-tf test))))
(and tf (funcall tf item))))
@@ -433,7 +433,13 @@
(multiple-value-bind
(m2 f2) (list-tp-test tf (info-type (cadadr nargs)))
(declare (ignore f2))
- (let ((m2 (or m2 (when (constantp (caddr args)) (every (car ltf)
(cmp-eval (caddr args)))))))
+ (let ((m2 (or m2
+ (let* ((ret (and (constantp (cadddr args)) (cadr
(member :ret (cmp-eval (cadddr args))))))
+ (k1 (when ret (cadr (member :k1 (cadddr
args))))))
+ (when (constantp k1)
+ (when (constantp (caddr args))
+ (let ((z (cmp-eval (caddr args))))
+ (every (car ltf) (if k1 (mapcar (cmp-eval k1)
z) z)))))))))
(cond ((or m1 m2) (c1t))
(f1 (c1nil))
((let ((info (make-info)))
@@ -443,12 +449,12 @@
(defun do-predicate (fn args)
(let* ((info (make-info :type 'boolean))
(nargs (c1args args info))
- (tp (car (rassoc fn +type-alist+))))
- (let ((at (and (not (cdr args)) (info-type (cadar nargs)))))
+ (tp (car (rassoc fn +cmp-type-alist+))))
+ (let ((at (and (not (cdr args)) (coerce-to-one-value (info-type (cadar
nargs))))))
(cond ((and at (type>= tp at)) (c1t))
((not (type-and at tp)) (c1nil))
((list 'call-global info fn nargs))))))
-(dolist (l +type-alist+) (when (symbolp (cdr l)) (si::putprop (cdr l)
'do-predicate 'c1g)))
+(dolist (l +cmp-type-alist+) (when (symbolp (cdr l)) (si::putprop (cdr l)
'do-predicate 'c1g)))
;(defun c1or (args)
; (cond ((null args) (c1expr nil))
@@ -513,13 +519,13 @@
(let ((v (cmp-eval (car args))))
(list (if (listp v) v (list v))))))
((one-int-tp st))
- ((not (type-and 'list (nil-to-t st))) `((*)))
+ ((not (type-and #tlist (nil-to-t st))) `((*)))
((and (eq (caar nargs) 'call-global) (eq (caddar
nargs) 'list))
`(,(mapcar (lambda (x) (let ((tp (cmp-norm-tp
(info-type (cadr x)))))
(or (caar (one-int-tp tp))
`*)))
(fourth (car nargs)))))
(`(*))))))
- (setf (info-type info) `(array ,@eltp ,@szf))
+ (setf (info-type info) (cmp-norm-tp `(array ,@eltp ,@szf)))
(list 'call-global info 'make-array nargs)))))
(si::putprop 'make-array 'c1make-array 'c1)
@@ -629,14 +635,14 @@
(integerp (car specs))
(< (+ (car specs)(cdr specs))
len)
- (type>= 'fixnum (result-type (second args))))
+ (type>= #tfixnum (result-type (second args))))
(c1expr `(the fixnum (si::ldb1 ,(car specs) ,(cdr specs) ,(second
args))))))))
(si:putprop 'length 'c1length 'c1)
(defun c1length (args &aux (info (make-info)))
- (setf (info-type info) 'seqind)
+ (setf (info-type info) #tseqind)
(cond ((and (consp (car args))
(eq (caar args) 'symbol-name)
(let ((args1 (cdr (car args))))
@@ -683,7 +689,7 @@
`(let ((,c ,(second args)))
(declare (type ,(result-type (second args))
,c))
- (and (typep ,c 'character)
+ (and (typep ,c #tcharacter)
(= (char-code ,(car args))
(the fixnum
(char-code
@@ -712,7 +718,8 @@
(defun co1typep (f args &aux tem) f
(let* ((x (car args)) new
- (type (and (literalp (cadr args)) (cmp-eval (cadr args)))))
+ (type (and (literalp (cadr args)) (cmp-norm-tp (cmp-eval (cadr
args)))))
+ (type (unless (eq type '*) type)))
(let* ((rt (result-type (car args)))
(ta (type-and rt type)))
; (format t "~a ~a ~a ~a~%" type rt ta (eq ta rt))
@@ -725,21 +732,20 @@
(setq new
(cond
((null type) nil)
- ((and (setq f (assoc type +type-alist+ :test 'equal))
+ ((and (setq f (assoc type +cmp-type-alist+ :test 'equal))
(not (get (cdr f) 'si::struct-predicate)))
(list (cdr f) x))
((and (consp type)
- (or (and (eq (car type) 'vector)
+ (or (and (eq (car type) #tvector)
(null (cddr type)))
(and
(member (car type)
- '(array vector simple-array))
+ #l(array vector simple-array))
(equal (third type) '(*)))))
- (setq tem (si::best-array-element-type
- (second type)))
- (cond ((eq tem 'character) `(stringp ,x))
- ((eq tem 'bit) `(bit-vector-p ,x))
- ((setq tem (position tem +array-types+))
+ (setq tem (cmp-norm-tp (si::best-array-element-type (second type))))
+ (cond ((eq tem #tcharacter) `(stringp ,x))
+ ((eq tem #tbit) `(bit-vector-p ,x))
+ ((setq tem (position tem +cmp-array-types+))
`(the boolean (vector-type ,x ,tem)))))
((and (consp type)
(eq (car type) 'satisfies)
@@ -749,14 +755,14 @@
(symbol-package (cadr type))
(null (cddr type))
`(,(cadr type) ,x)))
- ((type>= 'fixnum type)
+ ((type>= #tfixnum type)
(setq tem (cmp-norm-tp type))
(and (consp tem)
(si::fixnump (second tem))
(si::fixnump (third tem))
`(let ((.tem ,x))
(declare (type ,(result-type x) .tem))
- (and (typep .tem 'fixnum)
+ (and (si::fixnump .tem)
(>= (the fixnum .tem) ,(second tem))
(<= (the fixnum .tem) ,(third tem))))))
((and (symbolp type)
@@ -974,19 +980,8 @@
-
(defun aet-c-type (type)
- (ecase type
- ((t) "object")
- ((character signed-char non-negative-char) "char")
- ((non-negative-fixnum fixnum) "fixnum")
- (unsigned-char "unsigned char")
- ((signed-short non-negative-short) "short")
- (unsigned-short "unsigned short")
- ((signed-int non-negative-int) "int")
- (unsigned-int "unsigned int")
- (long-float "longfloat")
- (short-float "shortfloat")))
+ (or (cdr (assoc type +c-type-string-alist+)) (baboon)))
(si:putprop 'vector-push 'co1vector-push 'co1)
@@ -1068,9 +1063,13 @@
((prog prog*)
`(,f ,(car args)
,@ (fixup (cdr args)))))))))
+
+(defun sublis1 (x y z)
+ (format t "Should never be called: ~s ~s ~s~%" x y z))
+
(si::putprop 'sublis 'co1sublis 'co1)
(defun co1sublis (f args &aux test) f
- (and (case (length args)
+ (and (case (length args);FIXME
(2 (setq test 'eql1))
(4 (and (eq (third args) :test)
(cond ((member (fourth args) '(equal (function equal))) (setq
test 'equal1))
@@ -1081,6 +1080,21 @@
(c1expr `(let ((,s ,(car args)))
(sublis1 ,s ,(second args) ',test))))))
+;; (defun c1sublis1 (args)
+;; (let* ((info (make-info :type 'list))
+;; (args (c1args args info)))
+;; (list 'sublis1 info args)))
+;; (si:putprop 'sublis1 'c1sublis1 'c1)
+
+;; (defun c2sublis1 (args)
+;; (let* ((args (inline-args args '(t t)))
+;; (a (car args))
+;; (b (cadr args))
+;; (c (caddr args)))
+;; (let ((tst (car (rassoc (cadr c) *objects* :key 'car))))
+;; (unless (member tst '(eq equal1 eql1)) (error "bad test"))
+;; (wt "check_alist(" a ");sublis1(" a "," b "," (format nil "~(&~a~));"
tst)))))
+;; (si:putprop 'sublis1 'c2sublis1 'c2)
(defun sublis1-inline (a b c)
(let ((tst (car (find (cadr c) *objects* :key 'cadr))))
Index: cmpnew/gcl_cmpif.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpif.lsp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -b -r1.17 -r1.18
--- cmpnew/gcl_cmpif.lsp 16 May 2006 16:38:45 -0000 1.17
+++ cmpnew/gcl_cmpif.lsp 17 Jun 2006 19:26:58 -0000 1.18
@@ -60,10 +60,10 @@
(defun two-tp-inf (fn t2);;FIXME use num type bounds here for or types
(case fn
- ((> >=) (if (and (consp t2) (member (car t2) '(integer short-float
long-float)))
- `(real ,(or (cadr t2) '*)) t))
- ((< <=) (if (and (consp t2) (member (car t2) '(integer short-float
long-float)))
- `(real * ,(or (caddr t2) '*)) t))))
+ ((> >=) (if (and (consp t2) (member (car t2) #l(integer short-float
long-float)))
+ (cmp-norm-tp `(real ,(or (cadr t2) '*))) t))
+ ((< <=) (if (and (consp t2) (member (car t2) #l(integer short-float
long-float)))
+ (cmp-norm-tp `(real * ,(or (caddr t2) '*))) t))))
(defmacro vl-name (x) `(var-name (car (third ,x))))
(defmacro itp (x) `(info-type (second ,x)))
@@ -81,11 +81,12 @@
(fmla-and (reduce (reduce-lambda (x y) (tp-reduce 'type-and 'type-or1 x
y nil)) (maplist 'fmla-infer-tp (cdr fmla))))
(fmla-or (reduce (reduce-lambda (x y) (tp-reduce 'type-or1 'type-and x
y nil)) (maplist 'fmla-infer-tp (cdr fmla))))
(fmla-not (mapcar (lambda (x) (cons (car x) (cons (cddr x) (cadr x))))
(fmla-infer-tp (cdr fmla))))
- (var (when (vlp fmla) (list (cons (var-name (car (third fmla))) (cons
'(not null) 'null)))))
+ (var (when (vlp fmla) (list (cons (var-name (car (third fmla))) (cons
#t(not null) #tnull)))))
(call-global
(let* ((fn (third fmla)) (rfn (cdr (assoc fn +bool-inf-op-list+)))
- (args (fourth fmla)) (l (length args)) (pt (get fn
'si::predicate-type)))
- (cond ((and (= l 1) (vlp (first args)) pt) (list (cons (vl-name
(first args)) (cons pt `(not ,pt)))))
+ (args (fourth fmla)) (l (length args)) (pt (get fn
'si::predicate-type)));FIXME +cmp-type-alist+
+ (cond ((and (= l 1) (vlp (first args)) pt)
+ (list (cons (vl-name (first args)) (cons (cmp-norm-tp pt)
(cmp-norm-tp `(not ,pt))))))
((and (= l 2) rfn)
(let (r)
(when (vlp (first args))
@@ -143,7 +144,7 @@
(setf (var-type (car l)) (type-and
(cadr l) (cdr (caddr l)))))
(c1expr* (caddr args) info)))))
(setf (info-type info) (type-or1 (info-type (cadr tb))
- (if (endp (cddr args))
'null
+ (if (endp (cddr args))
#tnull
(info-type (cadr fb)))))
(do ((l (pop *restore-vars*) (pop *restore-vars*))) ((not
l))
(push (list (car l) (var-type (car l))) trv)
@@ -177,8 +178,8 @@
(fmla-not (t-not (fmla-eval-const (cdr fmla))))
(location (caddr fmla))
((t nil) (car fmla))
- (var (cond ((type>= 'null (info-type (second fmla))) nil)
- ((type>= '(not null) (info-type (second fmla))) t)
+ (var (cond ((type>= #tnull (info-type (second fmla))) nil)
+ ((type>= #t(not null) (info-type (second fmla))) t)
('boolean)))
(otherwise (if (consp (car fmla))
(fmla-eval-const (car fmla))
@@ -468,7 +469,7 @@
(let* ((info (make-info :type nil))
(key-form (c1expr* (car args) info))
(clauses nil) or-list)
- (cond ((type>= 'fixnum (info-type (second key-form)))
+ (cond ((type>= #tfixnum (info-type (second key-form)))
(return-from c1case (c1expr (convert-case-to-switch
args default )))))
(dolist (clause (cdr args))
Index: cmpnew/gcl_cmpinline.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpinline.lsp,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -b -r1.41 -r1.42
--- cmpnew/gcl_cmpinline.lsp 5 Jun 2006 22:02:45 -0000 1.41
+++ cmpnew/gcl_cmpinline.lsp 17 Jun 2006 19:26:58 -0000 1.42
@@ -22,35 +22,6 @@
(in-package 'compiler)
-(import 'si::proclaimed-arg-types 'compiler)
-(import 'si::proclaimed-return-type 'compiler)
-(import 'si::proclaimed-function 'compiler)
-(import 'si::proper-list 'compiler)
-(import 'si::subtypep1 'compiler)
-(import 'si::resolve-type 'compiler)
-(import 'si::+inf 'compiler)
-(import 'si::-inf 'compiler)
-(import 'si::nan 'compiler)
-(import 'si::isfinite 'compiler)
-(import 'si::+type-alist+ 'compiler)
-(import 'si::sequencep 'compiler)
-(import 'si::ratiop 'compiler)
-(import 'si::short-float-p 'compiler)
-(import 'si::long-float-p 'compiler)
-(import 'si::interpreted-function 'compiler)
-(import 'si::eql-is-eq 'compiler)
-(import 'si::equal-is-eq 'compiler)
-(import 'si::equalp-is-eq 'compiler)
-(import 'si::eql-is-eq-tp 'compiler)
-(import 'si::equal-is-eq-tp 'compiler)
-(import 'si::equalp-is-eq-tp 'compiler)
-(import 'si::is-eq-test-item-list 'compiler)
-(import 'si::cmp-vec-length 'compiler)
-(import 'si::proclaim-from-argd 'compiler)
-(let ((p (find-package "DEFPACKAGE")))
- (when p
- (import (find-symbol "DEFPACKAGE" p) 'compiler)))
-
(defmacro is-setf-function (name)
`(and (consp ,name) (eq (car ,name) 'setf)
(consp (cdr ,name)) (symbolp (cadr ,name))
@@ -68,7 +39,7 @@
(defmacro mia (x y) `(make-array ,x :adjustable t :fill-pointer ,y))
(defmacro eql-not-nil (x y) `(and ,x (eql ,x ,y)))
-(defstruct (info (:copier old-copy-info))
+(defstruct (info (:copier old-copy-info) (:constructor old-make-info))
(type t) ;;; Type of the form.
(sp-change nil) ;;; Whether execution of the form may change
;;; the value of a special variable *VS*.
@@ -88,25 +59,32 @@
;; allocate them on the local stack and save gc, but cannot be passed
;; as function arguments or returned therefrom. 20050707 CM.
-(defconstant +c-global-arg-types+ `(fixnum)) ;FIXME (long-float short-float)
later
-(defconstant +c-local-arg-types+ (union +c-global-arg-types+ '(fixnum
character long-float short-float)))
-(defconstant +c-local-var-types+ (union +c-local-arg-types+ '(fixnum
character long-float short-float integer)))
+(defconstant +c-global-arg-types-syms+ `(fixnum)) ;FIXME (long-float
short-float) later
+(defconstant +c-local-arg-types-syms+ (union +c-global-arg-types-syms+
'(fixnum character long-float short-float)))
+(defconstant +c-local-var-types-syms+ (union +c-local-arg-types-syms+
'(fixnum character long-float short-float integer)))
(defun get-sym (args)
(intern (apply 'concatenate 'string (mapcar 'string args))))
(defconstant +set-return-alist+
- (mapcar (lambda (x) (cons (get-sym `("RETURN-" ,x)) (get-sym `("SET-RETURN-"
,x)))) +c-local-arg-types+))
+ (mapcar (lambda (x) (cons (get-sym `("RETURN-" ,x)) (get-sym `("SET-RETURN-"
,x)))) +c-local-arg-types-syms+))
(defconstant +return-alist+
- (mapcar (lambda (x) (cons x (get-sym `("RETURN-" ,x)))) (cons 'object
+c-local-arg-types+)))
+ (mapcar (lambda (x) (cons (if (eq x 'object) x (cmp-norm-tp x)) (get-sym
`("RETURN-" ,x)))) (cons 'object +c-local-arg-types-syms+)))
(defconstant +wt-loc-alist+
`((object . wt-loc)
- ,@(mapcar (lambda (x) (cons x (get-sym `("WT-" ,x "-LOC"))))
+c-local-var-types+)))
+ ,@(mapcar (lambda (x) (cons (cmp-norm-tp x) (get-sym `("WT-" ,x "-LOC"))))
+c-local-var-types-syms+)))
(defconstant +coersion-alist+
- (mapcar (lambda (x) (cons x (get-sym `(,x "-LOC")))) +c-local-var-types+))
+ (mapcar (lambda (x) (cons (cmp-norm-tp x) (get-sym `(,x "-LOC"))))
+c-local-var-types-syms+))
(defconstant +inline-types-alist+
- `((boolean . inline-cond) (t . inline)
- ,@(mapcar (lambda (x) (cons x (get-sym `("INLINE-" ,x))))
+c-local-var-types+)))
+ `((,#tboolean . inline-cond) (t . inline)
+ ,@(mapcar (lambda (x) (cons (cmp-norm-tp x) (get-sym `("INLINE-" ,x))))
+c-local-var-types-syms+)))
+
+(defconstant +c-global-arg-types+ (mapcar 'cmp-norm-tp
+c-global-arg-types-syms+)) ;FIXME (long-float short-float) later
+(defconstant +c-local-arg-types+ (mapcar 'cmp-norm-tp
+c-local-arg-types-syms+))
+(defconstant +c-local-var-types+ (mapcar 'cmp-norm-tp
+c-local-var-types-syms+))
+
+
+
(defun copy-array (array)
(declare ((vector t) array))
@@ -124,13 +102,22 @@
(copy-array (info-changed-array info)))
new-info))
+(defun make-info (&rest args)
+ (let ((z (member :type args)))
+ (if z (apply 'old-make-info (mapcar (lambda (x) (if (eq x (cadr z))
(cmp-norm-tp x) x)) args))
+ (apply 'old-make-info args))))
+
+(defconstant +c1nil+ (list 'LOCATION (make-info :type (object-type nil)) nil))
+(defmacro c1nil () `+c1nil+)
+(defconstant +c1t+ (list 'LOCATION (make-info :type (object-type t)) t))
+(defmacro c1t () `+c1t+)
+
(defun bsearchleq (x a i j le)
- (declare (object x le) ((vector t) a) (fixnum i j))
- (when (eql i j)
+ (declare ((vector t) a) (seqind i j))
+ (when (= i j)
(return-from bsearchleq (if (or le (and (< i (length a)) (eq x (aref a
i)))) i (length a))))
- (let* ((k (the fixnum (+ i (the fixnum (ash (the fixnum (- j i) ) -1)))))
+ (let* ((k (+ i (ash (- j i) -1)))
(y (aref a k)))
- (declare (fixnum k) (object y))
(cond ((si::objlt x y)
(bsearchleq x a i k le))
((eq x y) k)
@@ -228,8 +215,12 @@
to-info)
(defun args-info-changed-vars (var forms)
+ (if (member (var-kind var) #l(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT))
+ (dolist** (form forms)
+ (when (is-changed var (cadr form))
+ (return-from args-info-changed-vars t)))
(case (var-kind var)
- ((LEXICAL FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
+ ((LEXICAL OBJECT)
(dolist** (form forms)
(when (is-changed var (cadr form))
(return-from args-info-changed-vars t))))
@@ -237,8 +228,7 @@
(t (dolist** (form forms nil)
(when (or (is-changed var (cadr form))
(info-sp-change (cadr form)))
- (return-from args-info-changed-vars t)))))
- )
+ (return-from args-info-changed-vars t)))))))
;; Variable references in arguments can also be via replaced variables
;; (see gcl_cmplet.lsp) It appears that this is not necessary when
@@ -266,8 +256,13 @@
(return-from is-rep-referred t))))))
(defun args-info-referred-vars (var forms)
+ (if (member (var-kind var) #l(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT))
+ (dolist** (form forms nil)
+ (when (or (is-referred var (cadr form))
+ (is-rep-referred var (cadr form)))
+ (return-from args-info-referred-vars t)))
(case (var-kind var)
- ((LEXICAL REPLACED FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
+ ((LEXICAL REPLACED OBJECT)
(dolist** (form forms nil)
(when (or (is-referred var (cadr form))
(is-rep-referred var (cadr form)))
@@ -276,8 +271,7 @@
(when (or (is-referred var (cadr form))
(is-rep-referred var (cadr form))
(info-sp-change (cadr form)))
- (return-from args-info-referred-vars t))))
- ))
+ (return-from args-info-referred-vars t)))))))
;;; Valid property names for open coded functions are:
;;; INLINE
@@ -319,6 +313,9 @@
(let ((form (car forms))
(type (car types)))
(declare (object form type))
+ (let ((type (cond ((type>= type t) type)
+ ((type>= type (info-type (cadr form)))
(promoted-c-type (type-and type (info-type (cadr form)))))
+ (type))));FIXME fixnum-float support
(case (car form)
(LOCATION (push (coerce-loc (caddr form) type) locs))
(VAR
@@ -330,8 +327,7 @@
(var-loc (caaddr form)) ";")
(push (list 'cvar cvar 'inline-args) locs)
(inc-inline-blocks)))
- (t
- (let ((temp (wt-c-push type)))
+ ((let ((temp (wt-c-push type)))
(wt-nl temp "= ")
(wt-var (caaddr form) (cadr (caddr form)))
(wt ";")
@@ -342,7 +338,7 @@
(wt-nl "V" temp " = "
(coerce-loc (cons 'var (caddr form)) type) ";")
(push (list 'cvar temp) locs)))
- (t (push (coerce-loc (cons 'VAR (caddr form)) type)
+ ((push (coerce-loc (cons 'VAR (caddr form)) type)
locs))))
(CALL-GLOBAL
(if (let ((fname (caddr form)))
@@ -356,7 +352,7 @@
((or (and (flag-p (caddr ii) ans)(not *c-gc*))
; returns new object
(and (member (cadr ii)
- '(FIXNUM LONG-FLOAT SHORT-FLOAT))
+ #l(FIXNUM LONG-FLOAT SHORT-FLOAT))
(not (eq type (cadr ii)))))
(let ((temp (cs-push type)))
(wt-nl "V" temp " = " (coerce-loc loc type) ";")
@@ -420,7 +416,7 @@
nil)))))
(let ((*value-to-go* temp))
(c2expr* form)
- (push (coerce-loc temp type) locs))))))))
+ (push (coerce-loc temp type) locs)))))))))
(defun coerce-loc (loc type)
(let ((tl (cdr (assoc (promoted-c-type type) +coersion-alist+))))
@@ -502,7 +498,7 @@
;; ( n . string , function ) or string , function
(when (and (setq x (get fname 'vfun))
- (if (and (consp x) (typep (car x) 'fixnum))
+ (if (and (consp x) (typep (car x) #tfixnum))
(prog1 (>= (length args) (car x)) (setq x (cdr x)))
t))
(return-from get-inline-info
@@ -517,7 +513,7 @@
(defun inline-type-matches (fname inline-info arg-types return-type
&aux (rts nil))
(declare (ignore fname))
- (if (not (typep (third inline-info) 'fixnum))
+ (if (not (typep (third inline-info) #tfixnum))
(fix-opt inline-info))
;; FIXME -- the idea here is that an inline might want to
;; force the coersion of certain arguments, notably fixnums,
@@ -537,13 +533,13 @@
(cond ((equal types '(*))
(setq types `(,last *))))
(let ((arg-type (coerce-to-one-value arg-type)))
- (cond ((eq (car types) 'fixnum-float)
- (cond ((type>= 'fixnum arg-type)
- (push 'fixnum rts))
- ((type>= 'long-float arg-type)
- (push 'long-float rts))
- ((type>= 'short-float arg-type)
- (push 'short-float rts))
+ (cond ((eq (car types) #tfixnum-float);FIXME remove?
+ (cond ((type>= #tfixnum arg-type)
+ (push #tfixnum rts))
+ ((type>= #tlong-float arg-type)
+ (push #tlong-float rts))
+ ((type>= #tshort-float arg-type)
+ (push #tshort-float rts))
(t (return nil))))
((type>= (car types) arg-type)
(push (car types) rts))
@@ -578,7 +574,7 @@
(VAR
(when (or (args-info-changed-vars (caaddr form) (cdr forms))
(and (member (var-kind (caaddr form))
- '(FIXNUM LONG-FLOAT SHORT-FLOAT))
+ #l(FIXNUM LONG-FLOAT SHORT-FLOAT))
(not (eq (car types)
(var-kind (caaddr form))))))
(return t)))
@@ -594,7 +590,7 @@
(flag-p (caddr ii) set)
(flag-p (caddr ii) is)
(and (member (cadr ii)
- '(fixnum long-float short-float))
+ #l(fixnum long-float short-float))
(not (eq (car types) (cadr ii))))
(need-to-protect (cadddr form) (car ii)))
(return t))))
@@ -762,20 +758,23 @@
;;FIXME -- All the var and C type code, e.g. var-type and var-kind, needs much
centralization.
;; 20050106 CM.
+;; (defun c-cast (aet)
+;; (case aet
+;; (signed-char "char")
+;; ((bit character unsigned-char non-negative-char) "unsigned char")
+;; (signed-short "short")
+;; ((non-negative-short unsigned-short) "unsigned short")
+;; (signed-int "int")
+;; ((non-negative-int unsigned-int) "unsigned int")
+;; ((signed-fixnum fixnum #tnon-negative-fixnum) "fixnum")
+;; ((unsigned-fixnum ) "object") ;FIXME
+;; (short-float "float")
+;; (long-float "double")
+;; ((t object) "object")
+;; (otherwise (baboon))))
(defun c-cast (aet)
- (case aet
- (signed-char "char")
- ((bit character unsigned-char non-negative-char) "unsigned char")
- (signed-short "short")
- ((non-negative-short unsigned-short) "unsigned short")
- (signed-int "int")
- ((non-negative-int unsigned-int) "unsigned int")
- ((signed-fixnum fixnum non-negative-fixnum) "fixnum")
- ((unsigned-fixnum ) "object") ;FIXME
- (short-float "float")
- (long-float "double")
- ((t object) "object")
- (otherwise (baboon))))
+ (or (cdr (assoc aet +c-type-string-alist+)) (baboon)))
+
;;FIXME -- This set of inlining/type-propagation work makes use of
@@ -806,8 +805,9 @@
(defun aref-propagator (fn x &rest inds)
(declare (ignore fn inds))
(let* ((x (cmp-norm-tp x)))
+ (cmp-norm-tp
(and (consp x) (member (car x) '(array simple-array))
- (and (not (eq (cadr x) '*)) (upgraded-array-element-type (nil-to-t
(cadr x)))))))
+ (and (not (eq (cadr x) '*)) (upgraded-array-element-type (nil-to-t
(cadr x))))))))
(defun var-array-type (a)
(when (consp a)
@@ -834,14 +834,14 @@
(let ((art (car r)))
(let ((aet (aref-propagator 'cmp-aref art)))
(if aet
- `((,art seqind) ,aet)
- `((t seqind) t)))))
+ `((,(cmp-norm-tp art) ,#tseqind) ,aet)
+ `((t ,#tseqind) t)))))
(defun cmp-aref-inline (a i)
(let ((at (nil-to-t (var-array-type a))))
(let ((aet (aref-propagator 'cmp-aref at)))
(if aet
- (if (eq aet 'bit)
+ (if (eq aet #tbit)
(progn
(wt "(((" (c-cast aet) " *)(" a ")->bv.bv_self)[")
(wt-bv-index a i)
@@ -858,8 +858,8 @@
(let ((art (car r)))
(let ((aet (aref-propagator 'cmp-aset art)))
(if aet
- `((,art seqind ,aet) ,aet)
- `((t seqind t) t)))))
+ `((,(cmp-norm-tp art) ,#tseqind ,aet) ,aet)
+ `((t ,#tseqind t) t)))))
@@ -868,7 +868,7 @@
(let ((at (nil-to-t (var-array-type a))))
(let ((aet (aref-propagator 'cmp-aset at)))
(if aet
- (if (eq aet 'bit)
+ (if (eq aet #tbit)
(progn
(wt "(" j " ? (((" (c-cast aet) " *)(" a ")->bv.bv_self)[")
(wt-bv-index a i)
@@ -887,8 +887,8 @@
;(proclaim '(ftype (function (t rnkind) seqind) cmp-array-dimension))
(defun cmp-array-dimension-inline-types (&rest r)
(if (aref-propagator 'cmp-array-dimension (car r))
- `((,(car r) rnkind) seqind)
- `((t rnkind) seqind)))
+ `((,(cmp-norm-tp (car r)) ,#trnkind) ,#tseqind)
+ `((t ,#trnkind) ,#tseqind)))
;;FIXME lose the normalize-type
@@ -917,18 +917,37 @@
;;; The value NIL for each parameter except for fname means "not known".
(when cname-string (si:putprop fname cname-string 'Lfun))
(when arg-types
- (si:putprop fname (mapcar #'(lambda (x)
- (if (eq x '*) '* (type-filter x)))
- arg-types) 'arg-types))
+ (si:putprop fname (mapcar 'cmp-norm-tp arg-types) 'arg-types))
(when return-type
- (let ((rt (function-return-type (if (atom return-type)
- (list return-type)
- return-type))))
+ (let ((rt (function-return-type (if (atom return-type) (list
return-type) return-type))))
(or (consp rt) (setq rt (list rt)))
- (si:putprop fname (if (null (cdr rt)) (car rt) (cons 'values rt))
- 'return-type)))
+ (si:putprop fname (type-filter (if (null (cdr rt)) (car rt) (cons
'values rt))) 'return-type)))
(when never-change-special-var-p (si:putprop fname t 'no-sp-change))
- (when predicate (si:putprop fname t 'predicate))
- )
+ (when predicate (si:putprop fname t 'predicate)))
+;;FIXME -- This function needs expansion on centralization. CM 20050106
+(defun promoted-c-type (type)
+ (let ((type (coerce-to-one-value type)))
+ (let ((ct (if (eq type 'object) type;FIXME!!!
+ (when type (car (member type
+; '(signed-char signed-short fixnum integer)
+; '(signed-char unsigned-char signed-short
unsigned-short fixnum integer)
+ `(,#tboolean ,@+c-local-var-types+)
+ :test 'type<=))))))
+ (cond (ct)
+; ((eq type 'boolean))
+ (type)))))
+; (or ct type))))
+; (if (integer-typep type)
+; (cond ;((subtypep type 'signed-char) 'signed-char)
+; ((subtypep type 'fixnum) 'fixnum)
+; ((subtypep type 'integer) 'integer)
+; (t (error "Cannot promote type ~S to C type~%" type)))
+; type)))
+
+(defun default-init (type)
+ (let ((type (promoted-c-type type)))
+ (when (member type +c-local-var-types+)
+ (cmpwarn "The default value of NIL is not ~S." type)))
+ (c1nil))
Index: cmpnew/gcl_cmplam.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmplam.lsp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -b -r1.14 -r1.15
--- cmpnew/gcl_cmplam.lsp 16 May 2006 16:38:45 -0000 1.14
+++ cmpnew/gcl_cmplam.lsp 17 Jun 2006 19:26:58 -0000 1.15
@@ -130,7 +130,7 @@
(defun decls-from-procls (ll procls body)
(cond ((or (null procls) (eq (car procls) '*)
- (null ll) (member (car ll) '(&whole &optional &rest &key
&environment) :test #'eq)) nil)
+ (null ll) (member (car ll) '(&whole &optional &rest &key
&environment))) nil)
((eq (car procls) t)
(decls-from-procls (cdr ll) (cdr procls) body))
(t
Index: cmpnew/gcl_cmplet.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmplet.lsp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -b -r1.26 -r1.27
--- cmpnew/gcl_cmplet.lsp 5 Jun 2006 22:21:08 -0000 1.26
+++ cmpnew/gcl_cmplet.lsp 17 Jun 2006 19:26:58 -0000 1.27
@@ -238,7 +238,7 @@
(let ((v (c1make-var x ss is ts)))
(push x vnames)
(push v vars)
- (set-var-init-type (car vars) 'null)
+ (set-var-init-type (car vars) #tnull)
(push (default-init (var-type v)) forms)))
(t (cmpck (not (and (consp x) (or (endp (cdr x)) (endp (cddr x)))))
"The variable binding ~s is illegal." x)
@@ -368,7 +368,7 @@
(push x vnames)
(push (default-init (var-type v)) forms)
(push v vars)
- (set-var-init-type (car vars) 'null)
+ (set-var-init-type (car vars) #tnull)
(push v *vars*)))
((not (and (consp x) (or (endp (cdr x)) (endp (cddr x)))))
(cmperr "The variable binding ~s is illegal." x))
Index: cmpnew/gcl_cmploc.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmploc.lsp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -b -r1.10 -r1.11
--- cmpnew/gcl_cmploc.lsp 12 Oct 2005 03:12:56 -0000 1.10
+++ cmpnew/gcl_cmploc.lsp 17 Jun 2006 19:26:58 -0000 1.11
@@ -189,11 +189,11 @@
(defun wt-fixnum-loc (loc)
(cond ((and (consp loc)
(eq (car loc) 'var)
- (eq (var-kind (cadr loc)) 'FIXNUM))
+ (eq (var-kind (cadr loc)) #tfixnum))
(wt "V" (var-loc (cadr loc))))
((and (consp loc)
(member (car loc)
- '(INLINE-FIXNUM INLINE-SHORT-FLOAT INLINE-LONG-FLOAT)
:test #'eq))
+ '(INLINE-FIXNUM INLINE-SHORT-FLOAT INLINE-LONG-FLOAT)))
(wt "(fixnum)")(wt-inline-loc (caddr loc) (cadddr loc)))
((and (consp loc) (eq (car loc) 'fixnum-value))
(wt "(fixnum)")(wt (caddr loc)))
@@ -208,10 +208,10 @@
(INLINE-INTEGER (setq avma nil) (wt-inline-loc (caddr loc) (cadddr loc)))
(fixnum-value (wt "stoi(" (caddr loc) ")"))
(var
- (case (var-kind (cadr loc))
- (integer (setq avma nil) (wt "V" (var-loc (cadr loc))))
- (fixnum (wt "stoi(V" (var-loc (cadr loc))")"))
- (otherwise (wt "otoi(" loc ")"))))
+ (cond
+ ((eq (var-kind (cadr loc)) #tinteger) (setq avma nil) (wt "V"
(var-loc (cadr loc))))
+ ((eq (var-kind (cadr loc)) #tfixnum) (wt "stoi(V" (var-loc (cadr
loc))")"))
+ ((wt "otoi(" loc ")"))))
(otherwise (wt "otoi(" loc ")")))
; (and avma (not *restore-avma*)(wfs-error))
)
@@ -220,7 +220,7 @@
(defun fixnum-loc-p (loc)
(and (consp loc)
(or (and (eq (car loc) 'var)
- (eq (var-kind (cadr loc)) 'FIXNUM))
+ (eq (var-kind (cadr loc)) #tfixnum))
(eq (car loc) 'INLINE-FIXNUM)
(eq (car loc) 'fixnum-value))))
@@ -232,7 +232,7 @@
(defun wt-character-loc (loc)
(cond ((and (consp loc)
(eq (car loc) 'var)
- (eq (var-kind (cadr loc)) 'CHARACTER))
+ (eq (var-kind (cadr loc)) #tcharacter))
(wt "V" (var-loc (cadr loc))))
((and (consp loc) (eq (car loc) 'INLINE-CHARACTER))
(wt-inline-loc (caddr loc) (cadddr loc)))
@@ -243,7 +243,7 @@
(defun character-loc-p (loc)
(and (consp loc)
(or (and (eq (car loc) 'var)
- (eq (var-kind (cadr loc)) 'CHARACTER))
+ (eq (var-kind (cadr loc)) #tcharacter))
(eq (car loc) 'INLINE-CHARACTER)
(eq (car loc) 'character-value))))
@@ -254,7 +254,7 @@
(defun wt-long-float-loc (loc)
(cond ((and (consp loc)
(eq (car loc) 'var)
- (eq (var-kind (cadr loc)) 'LONG-FLOAT))
+ (eq (var-kind (cadr loc)) #tlong-float))
(wt "V" (var-loc (cadr loc))))
((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT))
(wt-inline-loc (caddr loc) (cadddr loc)))
@@ -265,7 +265,7 @@
(defun long-float-loc-p (loc)
(and (consp loc)
(or (and (eq (car loc) 'var)
- (eq (var-kind (cadr loc)) 'LONG-FLOAT))
+ (eq (var-kind (cadr loc)) #tlong-float))
(eq (car loc) 'INLINE-LONG-FLOAT)
(eq (car loc) 'long-float-value))))
@@ -276,7 +276,7 @@
(defun wt-short-float-loc (loc)
(cond ((and (consp loc)
(eq (car loc) 'var)
- (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
+ (eq (var-kind (cadr loc)) #tshort-float))
(wt "V" (var-loc (cadr loc))))
((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT))
(wt-inline-loc (caddr loc) (cadddr loc)))
@@ -287,7 +287,7 @@
(defun short-float-loc-p (loc)
(and (consp loc)
(or (and (eq (car loc) 'var)
- (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
+ (eq (var-kind (cadr loc)) #tshort-float))
(eq (car loc) 'INLINE-SHORT-FLOAT)
(eq (car loc) 'short-float-value))))
Index: cmpnew/gcl_cmpmulti.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpmulti.lsp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -b -r1.21 -r1.22
--- cmpnew/gcl_cmpmulti.lsp 9 Jun 2006 20:50:58 -0000 1.21
+++ cmpnew/gcl_cmpmulti.lsp 17 Jun 2006 19:26:58 -0000 1.22
@@ -124,7 +124,7 @@
;; so if we know there's one value only:
(c1expr (let ((s (gensym))) `(let ((,s ,(car args))) ,s))))
(t (setq args (c1args args info))
- (setf (info-type info) (cons 'values (mapcar (lambda (x)
(coerce-to-one-value (info-type (cadr x)))) args)))
+ (setf (info-type info) (cmp-norm-tp (cons 'values (mapcar
(lambda (x) (coerce-to-one-value (info-type (cadr x)))) args))))
(list 'values info args))))
(defun c2values (forms &aux (base *vs*) (*vs* *vs*))
@@ -159,8 +159,8 @@
(push var vrefs)
(push-changed (car var) info)
)
- (setf (info-type info) (type-and (info-type (cadar (c1args (car args) info)))
- (info-type (cadar (c1args (cdr args)
info)))))
+ (setf (info-type info) (type-and (info-type (cadar (last (c1args (car args)
info))))
+ (info-type (cadar (last (c1args (cdr args)
info))))))
(let* ((v (c1expr* (cadr args) info))
(it (info-type (cadr v))))
(cond ((and (consp it) (eq (car it) 'values))
@@ -180,7 +180,8 @@
(and tem
;; proclaimed to have 1 arg:
(consp tem)
- (not (equal tem '(*)))
+; (not (equal tem '(*)))
+ (not (eq tem '*))
(null (cdr tem)))))
(cmpwarn "~A was proclaimed to have only one return value.
~%;But you appear to want multiple values." fname))))))
Index: cmpnew/gcl_cmpopt.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpopt.lsp,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -b -r1.33 -r1.34
--- cmpnew/gcl_cmpopt.lsp 5 Jun 2006 22:02:45 -0000 1.33
+++ cmpnew/gcl_cmpopt.lsp 17 Jun 2006 19:26:58 -0000 1.34
@@ -25,86 +25,92 @@
(or (fboundp 'flags) (load "../cmpnew/cmpeval.lsp"))
+(defmacro pushn (a b)
+ (let ((tmp (gensym)))
+ `(let ((,tmp `(,',(if (listp (caadr a)) (mapcar 'cmp-norm-tp (caadr a))
(caadr a))
+ ,',(cmp-norm-tp (cadadr a))
+ ,,@(mapcar (lambda (x) `',x) (cddadr a)))))
+ (push ,tmp ,b))))
;;BOOLE3
- (push '((fixnum fixnum fixnum) fixnum #.(flags rfa)INLINE-BOOLE3)
+ (pushn '((fixnum fixnum fixnum) fixnum #.(flags rfa)INLINE-BOOLE3)
(get 'boole3 'inline-always))
;;FP-OKP
- (push '((t) boolean #.(flags set rfa)
+ (pushn '((t) boolean #.(flags set rfa)
"@0;(type_of(#0)==t_stream? ((#0)->sm.sm_fp)!=0: 0 )")
(get 'fp-okp 'inline-unsafe))
-(push '((stream) boolean #.(flags set rfa)"((#0)->sm.sm_fp)!=0")
+(pushn '((stream) boolean #.(flags set rfa)"((#0)->sm.sm_fp)!=0")
(get 'fp-okp 'inline-unsafe))
;;LDB1
- (push '((fixnum fixnum fixnum) fixnum #.(flags)
+ (pushn '((fixnum fixnum fixnum) fixnum #.(flags)
"((((~(-1 << (#0))) << (#1)) & (#2)) >> (#1))")
(get 'si::ldb1 'inline-always))
;;LONG-FLOAT-P
- (push '((t) boolean #.(flags rfa)"type_of(#0)==t_longfloat")
+ (pushn '((t) boolean #.(flags rfa)"type_of(#0)==t_longfloat")
(get 'long-float-p 'inline-always))
;;SFEOF
- (push '((object) boolean #.(flags set rfa)"(feof((#0)->sm.sm_fp))")
+ (pushn '((t) boolean #.(flags set rfa)"(feof((#0)->sm.sm_fp))")
(get 'sfeof 'inline-unsafe))
;;SGETC1
- (push '((object) fixnum #.(flags set rfa) "getc((#0)->sm.sm_fp)")
+ (pushn '((t) fixnum #.(flags set rfa) "getc((#0)->sm.sm_fp)")
(get 'sgetc1 'inline-unsafe))
;;SPUTC
- (push '((fixnum object) fixnum #.(flags set rfa)"(putc(#0,(#1)->sm.sm_fp))")
+ (pushn '((fixnum t) fixnum #.(flags set rfa)"(putc(#0,(#1)->sm.sm_fp))")
(get 'sputc 'inline-unsafe))
-(push '((character object) fixnum #.(flags set rfa)"(putc(#0,(#1)->sm.sm_fp))")
+(pushn '((character t) fixnum #.(flags set rfa)"(putc(#0,(#1)->sm.sm_fp))")
(get 'sputc 'inline-unsafe))
;;FORK
- (push '(() t #.(flags)"myfork()")
+ (pushn '(() t #.(flags)"myfork()")
(get 'si::fork 'inline-unsafe))
;;READ-POINTER-OBJECT
- (push '((t) t #.(flags ans set)"read_pointer_object(#0)")
+ (pushn '((t) t #.(flags ans set)"read_pointer_object(#0)")
(get 'si::read-pointer-object 'inline-unsafe))
;;WRITE-POINTER-OBJECT
- (push '((t t) t #.(flags ans set)"write_pointer_object(#0,#1)")
+ (pushn '((t t) t #.(flags ans set)"write_pointer_object(#0,#1)")
(get 'si::write-pointer-object 'inline-unsafe))
;;READ-BYTE1
- (push '((t t) t #.(flags ans set)"read_byte1(#0,#1)")
+ (pushn '((t t) t #.(flags rfa ans set)"read_byte1(#0,#1)")
(get 'read-byte1 'inline-unsafe))
;;READ-CHAR1
- (push '((t t) t #.(flags ans set)"read_char1(#0,#1)")
+ (pushn '((t t) t #.(flags rfa ans set)"read_char1(#0,#1)")
(get 'read-char1 'inline-unsafe))
;;SHIFT<<
- (push '((fixnum fixnum) fixnum #.(flags)"((#0) << (#1))")
+ (pushn '((fixnum fixnum) fixnum #.(flags)"((#0) << (#1))")
(get 'shift<< 'inline-always))
;;SHIFT>>
- (push '((fixnum fixnum) fixnum #.(flags set rfa)"((#0) >> (- (#1)))")
+ (pushn '((fixnum fixnum) fixnum #.(flags set rfa)"((#0) >> (- (#1)))")
(get 'shift>> 'inline-always))
;;SHORT-FLOAT-P
- (push '((t) boolean #.(flags rfa)"type_of(#0)==t_shortfloat")
+ (pushn '((t) boolean #.(flags rfa)"type_of(#0)==t_shortfloat")
(get 'short-float-p 'inline-always))
;;SIDE-EFFECTS
- (push '(nil t #.(flags ans set)"Ct")
+ (pushn '(nil t #.(flags ans set)"Ct")
(get 'side-effects 'inline-always))
;;STACK-CONS ;;FIXME update this
-; (push '((fixnum t t) t #.(flags)
+; (pushn '((fixnum t t) t #.(flags)
; "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1),
; STcons#0.c_cdr=(#2),(object)&STcons#0)")
; (get 'stack-cons 'inline-always))
;;SUBLIS1
- (push '((t t t) t #.(flags ans set)SUBLIS1-INLINE)
+ (pushn '((t t t) t #.(flags rfa ans set)SUBLIS1-INLINE)
(get 'sublis1 'inline-always))
;;FIXME the MAX and MIN optimized arg evaluations aren't logically related to
side effects
@@ -114,186 +120,186 @@
;;ABS
; (si::putprop 'abs 'abs-propagator 'type-propagator)
- (push '(((integer #.(1+ most-negative-fixnum) #.most-positive-fixnum))
(integer 0 #.most-positive-fixnum) #.(flags rfa)"abs(#0)")
+ (pushn '(((integer #.(1+ most-negative-fixnum) #.most-positive-fixnum))
(integer 0 #.most-positive-fixnum) #.(flags rfa)"abs(#0)")
(get 'abs 'inline-always))
- (push '((short-float) (short-float 0.0) #.(flags rfa)"fabs(#0)") ;;FIXME
ranged floating point types
+ (pushn '((short-float) (short-float 0.0) #.(flags rfa)"fabs(#0)") ;;FIXME
ranged floating point types
(get 'abs 'inline-always))
- (push '((long-float) (long-float 0.0) #.(flags rfa)"fabs(#0)")
+ (pushn '((long-float) (long-float 0.0) #.(flags rfa)"fabs(#0)")
(get 'abs 'inline-always))
- (push '(((real 0.0)) t #.(flags)"#0")
+ (pushn '(((real 0.0)) t #.(flags)"#0")
(get 'abs 'inline-always))
;;SYMBOL-LENGTH
- (push '((t) fixnum #.(flags rfa set)
+ (pushn '((t) fixnum #.(flags rfa set)
"@0;(type_of(#0)==t_symbol ? (#0)->s.st_fillp :not_a_variable((#0)))")
(get 'symbol-length 'inline-always))
;;VECTOR-TYPE
- (push '((t fixnum) boolean #.(flags rfa)
+ (pushn '((t fixnum) boolean #.(flags rfa)
"@0;(type_of(#0) == t_vector && (#0)->v.v_elttype == (#1))")
(get 'vector-type 'inline-always))
;;SYSTEM:ASET
- (push '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)")
+ (pushn '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)")
(get 'system:aset 'inline-always))
-(push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)")
+(pushn '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)")
(get 'system:aset 'inline-always))
-(push '((t t t) t #.(flags set)"aset1(#0,fix(#1),#2)")
+(pushn '((t t t) t #.(flags set)"aset1(#0,fix(#1),#2)")
(get 'system:aset 'inline-unsafe))
-(push '(((array t) fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)")
+(pushn '(((array t) fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)")
(get 'system:aset 'inline-unsafe))
-(push '(((array character) fixnum character) character #.(flags rfa
set)"(#0)->ust.ust_self[#1]= (#2)")
+(pushn '(((array character) fixnum character) character #.(flags rfa
set)"(#0)->ust.ust_self[#1]= (#2)")
(get 'system:aset 'inline-unsafe))
-(push '(((array fixnum) fixnum fixnum) fixnum #.(flags set
rfa)"(#0)->fixa.fixa_self[#1]= (#2)")
+(pushn '(((array fixnum) fixnum fixnum) fixnum #.(flags set
rfa)"(#0)->fixa.fixa_self[#1]= (#2)")
(get 'system:aset 'inline-unsafe))
-(push '(((array signed-short) fixnum fixnum) fixnum #.(flags rfa set)"((short
*)(#0)->ust.ust_self)[#1]=(#2)")
+(pushn '(((array signed-short) fixnum fixnum) fixnum #.(flags rfa set)"((short
*)(#0)->ust.ust_self)[#1]=(#2)")
(get 'system:aset 'inline-unsafe))
-(push '(((array signed-char) fixnum fixnum) fixnum #.(flags rfa
set)"((#0)->ust.ust_self)[#1]=(#2)")
+(pushn '(((array signed-char) fixnum fixnum) fixnum #.(flags rfa
set)"((#0)->ust.ust_self)[#1]=(#2)")
(get 'system:aset 'inline-unsafe))
-(push '(((array unsigned-short) fixnum fixnum) fixnum #.(flags rfa set)
+(pushn '(((array unsigned-short) fixnum fixnum) fixnum #.(flags rfa set)
"((unsigned short *)(#0)->ust.ust_self)[#1]=(#2)")
(get 'system:aset 'inline-unsafe))
-(push '(((array unsigned-char) fixnum fixnum) fixnum #.(flags rfa
set)"((#0)->ust.ust_self)[#1]=(#2)")
+(pushn '(((array unsigned-char) fixnum fixnum) fixnum #.(flags rfa
set)"((#0)->ust.ust_self)[#1]=(#2)")
(get 'system:aset 'inline-unsafe))
-(push '(((array short-float) fixnum short-float) short-float #.(flags rfa
set)"(#0)->sfa.sfa_self[#1]= (#2)")
+(pushn '(((array short-float) fixnum short-float) short-float #.(flags rfa
set)"(#0)->sfa.sfa_self[#1]= (#2)")
(get 'system:aset 'inline-unsafe))
-(push '(((array long-float) fixnum long-float) long-float #.(flags rfa
set)"(#0)->lfa.lfa_self[#1]= (#2)")
+(pushn '(((array long-float) fixnum long-float) long-float #.(flags rfa
set)"(#0)->lfa.lfa_self[#1]= (#2)")
(get 'system:aset 'inline-unsafe))
-(push '((t t t t) t #.(flags set)
+(pushn '((t t t t) t #.(flags set)
"@0;aset(#0,fix(#1)*(#0)->a.a_dims[1]+fix(#2),#3)")
(get 'system:aset 'inline-unsafe))
-(push '(((array t) fixnum fixnum t) t #.(flags set)
+(pushn '(((array t) fixnum fixnum t) t #.(flags set)
"@0;(#0)->a.a_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)")
(get 'system:aset 'inline-unsafe))
-(push '(((array character) fixnum fixnum character) character
+(pushn '(((array character) fixnum fixnum character) character
#.(flags rfa set)
"@0;(#0)->ust.ust_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)")
(get 'system:aset 'inline-unsafe))
-(push '(((array fixnum) fixnum fixnum fixnum) fixnum #.(flags set rfa)
+(pushn '(((array fixnum) fixnum fixnum fixnum) fixnum #.(flags set rfa)
"@0;(#0)->fixa.fixa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)")
(get 'system:aset 'inline-unsafe))
-(push '(((array short-float) fixnum fixnum short-float) short-float #.(flags
rfa set)
+(pushn '(((array short-float) fixnum fixnum short-float) short-float #.(flags
rfa set)
"@0;(#0)->sfa.sfa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)")
(get 'system:aset 'inline-unsafe))
-(push '(((array long-float) fixnum fixnum long-float) long-float #.(flags rfa
set)
+(pushn '(((array long-float) fixnum fixnum long-float) long-float #.(flags rfa
set)
"@0;(#0)->lfa.lfa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)")
(get 'system:aset 'inline-unsafe))
;;SYSTEM:CHAR-SET
- (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)")
+ (pushn '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)")
(get 'system:char-set 'inline-always))
-(push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)")
+(pushn '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)")
(get 'system:char-set 'inline-always))
-(push '((t t t) t #.(flags set)
+(pushn '((t t t) t #.(flags set)
"@2;((#0)->ust.ust_self[fix(#1)]=char_code(#2),(#2))")
(get 'system:char-set 'inline-unsafe))
-(push '((t fixnum character) character #.(flags rfa
set)"(#0)->ust.ust_self[#1]= (#2)")
+(pushn '((t fixnum character) character #.(flags rfa
set)"(#0)->ust.ust_self[#1]= (#2)")
(get 'system:char-set 'inline-unsafe))
;;SYSTEM:ELT-SET
- (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)")
+ (pushn '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)")
(get 'system:elt-set 'inline-always))
-(push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)")
+(pushn '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)")
(get 'system:elt-set 'inline-always))
-(push '((t t t) t #.(flags set)"elt_set(#0,fix(#1),#2)")
+(pushn '((t t t) t #.(flags set)"elt_set(#0,fix(#1),#2)")
(get 'system:elt-set 'inline-unsafe))
;;SYSTEM:FILL-POINTER-SET
- (push '((t fixnum) seqind #.(flags rfa
set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) :
((#0)->st.st_fillp)))")
+ (pushn '((t fixnum) seqind #.(flags rfa
set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) :
((#0)->st.st_fillp)))")
(get 'system:fill-pointer-set 'inline-unsafe))
- (push '(((vector) seqind) seqind #.(flags rfa
set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) :
((#0)->st.st_fillp)))")
+ (pushn '(((vector) seqind) seqind #.(flags rfa
set)"(((#0)->st.st_fillp)=(((#0)->st.st_hasfillp) ? (#1) :
((#0)->st.st_fillp)))")
(get 'system:fill-pointer-set 'inline-always))
;;SYSTEM:FIXNUMP
- (push '((t) boolean #.(flags rfa)"type_of(#0)==t_fixnum")
+ (pushn '((t) boolean #.(flags rfa)"type_of(#0)==t_fixnum")
(get 'system:fixnump 'inline-always))
-(push '((fixnum) boolean #.(flags rfa)"1")
+(pushn '((fixnum) boolean #.(flags rfa)"1")
(get 'system:fixnump 'inline-always))
;;SYSTEM:SEQINDP
- (push '((t) boolean #.(flags rfa) #.(format nil "(type_of(#0)==t_fixnum &&
({fixnum _t=fix(#0);_t>=0 && _t<=~s;}))" array-dimension-limit))
+ (pushn '((t) boolean #.(flags rfa) #.(format nil "(type_of(#0)==t_fixnum &&
({fixnum _t=fix(#0);_t>=0 && _t<=~s;}))" array-dimension-limit))
(get 'system::seqindp 'inline-always))
-(push '((fixnum) boolean #.(flags rfa)#.(format nil "(#0>=0 && #0<=~s)"
array-dimension-limit))
+(pushn '((fixnum) boolean #.(flags rfa)#.(format nil "(#0>=0 && #0<=~s)"
array-dimension-limit))
(get 'system::seqindp 'inline-always))
-(push '((seqind) boolean #.(flags rfa)"1")
+(pushn '((seqind) boolean #.(flags rfa)"1")
(get 'system::seqindp 'inline-always))
;;SYSTEM:MV-REF
- (push '((fixnum) t #.(flags ans set)"(MVloc[(#0)])")
+ (pushn '((fixnum) t #.(flags ans set)"(MVloc[(#0)])")
(get 'system:mv-ref 'inline-always))
;;SYSTEM:PUTPROP
- (push '((t t t) t #.(flags set)"putprop(#0,#1,#2)")
+ (pushn '((t t t) t #.(flags set)"putprop(#0,#1,#2)")
(get 'system:putprop 'inline-always))
;;SYSTEM:SCHAR-SET
- (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)")
+ (pushn '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)")
(get 'system:schar-set 'inline-always))
-(push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)")
+(pushn '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)")
(get 'system:schar-set 'inline-always))
-(push '((t t t) t #.(flags set)
+(pushn '((t t t) t #.(flags set)
"@2;((#0)->ust.ust_self[fix(#1)]=char_code(#2),(#2))")
(get 'system:schar-set 'inline-unsafe))
-(push '((t fixnum character) character #.(flags set
rfa)"(#0)->ust.ust_self[#1]= (#2)")
+(pushn '((t fixnum character) character #.(flags set
rfa)"(#0)->ust.ust_self[#1]= (#2)")
(get 'system:schar-set 'inline-unsafe))
;;SYSTEM:SET-MV
- (push '((fixnum t) t #.(flags ans set)"(MVloc[(#0)]=(#1))")
+ (pushn '((fixnum t) t #.(flags ans set)"(MVloc[(#0)]=(#1))")
(get 'system:set-mv 'inline-always))
;;SYSTEM:SPUTPROP
- (push '((t t t) t #.(flags set)"sputprop(#0,#1,#2)")
+ (pushn '((t t t) t #.(flags set)"sputprop(#0,#1,#2)")
(get 'system:sputprop 'inline-always))
;;SYSTEM:STRUCTURE-DEF
- (push '((t) t #.(flags)"(#0)->str.str_def")
+ (pushn '((t) t #.(flags)"(#0)->str.str_def")
(get 'system:structure-def 'inline-unsafe))
;;SYSTEM:STRUCTURE-REF
- (push '((t t fixnum) t #.(flags ans)"structure_ref(#0,#1,#2)")
+ (pushn '((t t fixnum) t #.(flags ans)"structure_ref(#0,#1,#2)")
(get 'system:structure-ref 'inline-always))
;;SYSTEM:STRUCTURE-SET
- (push '((t t fixnum t) t #.(flags set)"structure_set(#0,#1,#2,#3)")
+ (pushn '((t t fixnum t) t #.(flags set)"structure_set(#0,#1,#2,#3)")
(get 'system:structure-set 'inline-always))
;;SYSTEM:STRUCTUREP
- (push '((t) boolean #.(flags rfa)"type_of(#0)==t_structure")
+ (pushn '((t) boolean #.(flags rfa)"type_of(#0)==t_structure")
(get 'system:structurep 'inline-always))
;;SYSTEM:SVSET
- (push '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)")
+ (pushn '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)")
(get 'system:svset 'inline-always))
-(push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)")
+(pushn '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)")
(get 'system:svset 'inline-always))
-(push '((t t t) t #.(flags set)"((#0)->v.v_self[fix(#1)]=(#2))")
+(pushn '((t t t) t #.(flags set)"((#0)->v.v_self[fix(#1)]=(#2))")
(get 'system:svset 'inline-unsafe))
-(push '((t fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)")
+(pushn '((t fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)")
(get 'system:svset 'inline-unsafe))
;;*
;(si::putprop '* 'super-range 'type-propagator)
-(push '((t t) t #.(flags ans)"number_times(#0,#1)")
+(pushn '((t t) t #.(flags ans)"number_times(#0,#1)")
(get '* 'inline-always))
-(push '((fixnum-float fixnum-float) short-float
#.(flags)"(double)(#0)*(double)(#1)")
+(pushn '((fixnum-float fixnum-float) short-float
#.(flags)"(double)(#0)*(double)(#1)")
(get '* 'inline-always))
-(push '((fixnum-float fixnum-float) long-float
#.(flags)"(double)(#0)*(double)(#1)")
+(pushn '((fixnum-float fixnum-float) long-float
#.(flags)"(double)(#0)*(double)(#1)")
(get '* 'inline-always))
-(push '((long-float long-float) long-float #.(flags
rfa)"(double)(#0)*(double)(#1)")
+(pushn '((long-float long-float) long-float #.(flags
rfa)"(double)(#0)*(double)(#1)")
(get '* 'inline-always))
-(push '((short-float short-float) short-float #.(flags rfa)"(#0)*(#1)")
+(pushn '((short-float short-float) short-float #.(flags rfa)"(#0)*(#1)")
(get '* 'inline-always))
-(push '((fixnum fixnum) fixnum #.(flags)"(#0)*(#1)")
+(pushn '((fixnum fixnum) fixnum #.(flags)"(#0)*(#1)")
(get '* 'inline-always))
;;ASH
;(si::putprop 'ash 'ash-propagator 'type-propagator)
-(push '(((integer 0 0) t) fixnum #.(flags rfa)"0")
+(pushn '(((integer 0 0) t) fixnum #.(flags rfa)"0")
(get 'ash 'inline-always))
-(push '((fixnum (integer 0 #.(integer-length most-positive-fixnum))) fixnum
#.(flags)"((#0)<<(#1))")
+(pushn '((fixnum (integer 0 #.(integer-length most-positive-fixnum))) fixnum
#.(flags)"((#0)<<(#1))")
(get 'ash 'inline-always))
-(push '((fixnum (integer #.most-negative-fixnum -1)) fixnum #.(flags set)
+(pushn '((fixnum (integer #.most-negative-fixnum -1)) fixnum #.(flags set)
#.(concatenate 'string "@1;(-(#1)&"
(write-to-string (lognot (integer-length
most-positive-fixnum)))
"? ((#0)>=0 ? 0 : -1) : (#0)>>-(#1))"))
@@ -302,531 +308,531 @@
;;+
;(si::putprop '+ 'super-range 'type-propagator)
-(push '((t t) t #.(flags ans)"number_plus(#0,#1)")
+(pushn '((t t) t #.(flags ans)"number_plus(#0,#1)")
(get '+ 'inline-always))
-(push '((fixnum-float fixnum-float) short-float
#.(flags)"(double)(#0)+(double)(#1)")
+(pushn '((fixnum-float fixnum-float) short-float
#.(flags)"(double)(#0)+(double)(#1)")
(get '+ 'inline-always))
-(push '((fixnum-float fixnum-float) long-float
#.(flags)"(double)(#0)+(double)(#1)")
+(pushn '((fixnum-float fixnum-float) long-float
#.(flags)"(double)(#0)+(double)(#1)")
(get '+ 'inline-always))
-(push '((long-float long-float) long-float #.(flags
rfa)"(double)(#0)+(double)(#1)")
+(pushn '((long-float long-float) long-float #.(flags
rfa)"(double)(#0)+(double)(#1)")
(get '+ 'inline-always))
-(push '((short-float short-float) short-float #.(flags rfa)"(#0)+(#1)")
+(pushn '((short-float short-float) short-float #.(flags rfa)"(#0)+(#1)")
(get '+ 'inline-always))
-(push '((fixnum fixnum) fixnum #.(flags)"(#0)+(#1)")
+(pushn '((fixnum fixnum) fixnum #.(flags)"(#0)+(#1)")
(get '+ 'inline-always))
;;-
;(si::putprop '- 'super-range 'type-propagator)
-(push '((t) t #.(flags ans)"number_negate(#0)")
+(pushn '((t) t #.(flags ans)"number_negate(#0)")
(get '- 'inline-always))
-(push '(((integer #.(1+ most-negative-fixnum) #.most-positive-fixnum)) fixnum
#.(flags)"-(#0)")
+(pushn '(((integer #.(1+ most-negative-fixnum) #.most-positive-fixnum)) fixnum
#.(flags)"-(#0)")
(get '- 'inline-always))
-(push '((t t) t #.(flags ans)"number_minus(#0,#1)")
+(pushn '((t t) t #.(flags ans)"number_minus(#0,#1)")
(get '- 'inline-always))
-(push '((fixnum-float fixnum-float) short-float
#.(flags)"(double)(#0)-(double)(#1)")
+(pushn '((fixnum-float fixnum-float) short-float
#.(flags)"(double)(#0)-(double)(#1)")
(get '- 'inline-always))
-(push '((fixnum-float) short-float #.(flags)"-(double)(#0)")
+(pushn '((fixnum-float) short-float #.(flags)"-(double)(#0)")
(get '- 'inline-always))
-(push '((fixnum-float) long-float #.(flags)"-(double)(#0)")
+(pushn '((fixnum-float) long-float #.(flags)"-(double)(#0)")
(get '- 'inline-always))
-(push '((fixnum-float fixnum-float) long-float
#.(flags)"(double)(#0)-(double)(#1)")
+(pushn '((fixnum-float fixnum-float) long-float
#.(flags)"(double)(#0)-(double)(#1)")
(get '- 'inline-always))
-(push '((long-float long-float) long-float #.(flags
rfa)"(double)(#0)-(double)(#1)")
+(pushn '((long-float long-float) long-float #.(flags
rfa)"(double)(#0)-(double)(#1)")
(get '- 'inline-always))
-(push '((short-float short-float) short-float #.(flags rfa)"(#0)-(#1)")
+(pushn '((short-float short-float) short-float #.(flags rfa)"(#0)-(#1)")
(get '- 'inline-always))
-(push '((fixnum fixnum) fixnum #.(flags)"(#0)-(#1)")
+(pushn '((fixnum fixnum) fixnum #.(flags)"(#0)-(#1)")
(get '- 'inline-always))
-(push '((fixnum) fixnum #.(flags)"-(#0)")
+(pushn '((fixnum) fixnum #.(flags)"-(#0)")
(get '- 'inline-always))
;;/
-(push '((fixnum fixnum) fixnum #.(flags)"(#0)/(#1)")
+(pushn '((fixnum fixnum) fixnum #.(flags)"(#0)/(#1)")
(get '/ 'inline-always))
- (push '((fixnum-float fixnum-float) short-float
#.(flags)"(double)(#0)/(double)(#1)")
+ (pushn '((fixnum-float fixnum-float) short-float
#.(flags)"(double)(#0)/(double)(#1)")
(get '/ 'inline-always))
-(push '((fixnum-float fixnum-float) long-float
#.(flags)"(double)(#0)/(double)(#1)")
+(pushn '((fixnum-float fixnum-float) long-float
#.(flags)"(double)(#0)/(double)(#1)")
(get '/ 'inline-always))
-(push '((long-float long-float) long-float #.(flags
rfa)"(double)(#0)/(double)(#1)")
+(pushn '((long-float long-float) long-float #.(flags
rfa)"(double)(#0)/(double)(#1)")
(get '/ 'inline-always))
-(push '((short-float short-float) short-float #.(flags rfa)"(#0)/(#1)")
+(pushn '((short-float short-float) short-float #.(flags rfa)"(#0)/(#1)")
(get '/ 'inline-always))
;;/=
- (push '((t t) boolean #.(flags rfa)"number_compare(#0,#1)!=0")
+ (pushn '((t t) boolean #.(flags rfa)"number_compare(#0,#1)!=0")
(get '/= 'inline-always))
-(push '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)!=(#1)")
+(pushn '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)!=(#1)")
(get '/= 'inline-always))
;;1+
- (push '((t) t #.(flags ans)"one_plus(#0)")
+ (pushn '((t) t #.(flags ans)"one_plus(#0)")
(get '1+ 'inline-always))
-(push '((fixnum-float) short-float #.(flags)"(double)(#0)+1")
+(pushn '((fixnum-float) short-float #.(flags)"(double)(#0)+1")
(get '1+ 'inline-always))
-(push '((fixnum-float) long-float #.(flags)"(double)(#0)+1")
+(pushn '((fixnum-float) long-float #.(flags)"(double)(#0)+1")
(get '1+ 'inline-always))
-(push '((fixnum) fixnum #.(flags)"(#0)+1")
+(pushn '((fixnum) fixnum #.(flags)"(#0)+1")
(get '1+ 'inline-always))
;;1-
- (push '((t) t #.(flags ans)"one_minus(#0)")
+ (pushn '((t) t #.(flags ans)"one_minus(#0)")
(get '1- 'inline-always))
-(push '((fixnum) fixnum #.(flags)"(#0)-1")
+(pushn '((fixnum) fixnum #.(flags)"(#0)-1")
(get '1- 'inline-always))
-(push '((fixnum-float) short-float #.(flags)"(double)(#0)-1")
+(pushn '((fixnum-float) short-float #.(flags)"(double)(#0)-1")
(get '1- 'inline-always))
-(push '((fixnum-float) long-float #.(flags)"(double)(#0)-1")
+(pushn '((fixnum-float) long-float #.(flags)"(double)(#0)-1")
(get '1- 'inline-always))
;;<
- (push '((t t) boolean #.(flags rfa)"number_compare(#0,#1)<0")
+ (pushn '((t t) boolean #.(flags rfa)"number_compare(#0,#1)<0")
(get '< 'inline-always))
-(push '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)<(#1)")
+(pushn '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)<(#1)")
(get '< 'inline-always))
;;compiler::objlt
- (push '((t t) boolean #.(flags rfa)"((object)(#0))<((object)(#1))")
+ (pushn '((t t) boolean #.(flags rfa)"((object)(#0))<((object)(#1))")
(get 'si::objlt 'inline-always))
;;<=
-(push '((t t) boolean #.(flags rfa)"number_compare(#0,#1)<=0")
+(pushn '((t t) boolean #.(flags rfa)"number_compare(#0,#1)<=0")
(get '<= 'inline-always))
-(push '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)<=(#1)")
+(pushn '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)<=(#1)")
(get '<= 'inline-always))
;;=
-(push '((t t) boolean #.(flags rfa)"number_compare(#0,#1)==0")
+(pushn '((t t) boolean #.(flags rfa)"number_compare(#0,#1)==0")
(get '= 'inline-always))
-(push '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)==(#1)")
+(pushn '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)==(#1)")
(get '= 'inline-always))
;;>
-(push '((t t) boolean #.(flags rfa)"number_compare(#0,#1)>0")
+(pushn '((t t) boolean #.(flags rfa)"number_compare(#0,#1)>0")
(get '> 'inline-always))
-(push '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)>(#1)")
+(pushn '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)>(#1)")
(get '> 'inline-always))
;;>=
- (push '((t t) boolean #.(flags rfa)"number_compare(#0,#1)>=0")
+ (pushn '((t t) boolean #.(flags rfa)"number_compare(#0,#1)>=0")
(get '>= 'inline-always))
-(push '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)>=(#1)")
+(pushn '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)>=(#1)")
(get '>= 'inline-always))
;;APPEND
- (push '((t t) t #.(flags ans)"append(#0,#1)")
+ (pushn '((t t) t #.(flags ans)"append(#0,#1)")
(get 'append 'inline-always))
;;AREF
-;(push '((t t) t #.(flags ans)"aref1(#0,fixint(#1))")
+;(pushn '((t t) t #.(flags ans)"aref1(#0,fixint(#1))")
; (get 'aref 'inline-always))
-;(push '((t fixnum) t #.(flags ans)"aref1(#0,#1)")
+;(pushn '((t fixnum) t #.(flags ans)"aref1(#0,#1)")
; (get 'aref 'inline-always))
-;(push '((t t) t #.(flags ans)"aref1(#0,fix(#1))")
+;(pushn '((t t) t #.(flags ans)"aref1(#0,fix(#1))")
; (get 'aref 'inline-unsafe))
-;(push '(((array t) fixnum) t #.(flags)"(#0)->v.v_self[#1]")
+;(pushn '(((array t) fixnum) t #.(flags)"(#0)->v.v_self[#1]")
; (get 'aref 'inline-unsafe))
-;(push '(((array character) fixnum) character #.(flags
rfa)"(#0)->ust.ust_self[#1]")
+;(pushn '(((array character) fixnum) character #.(flags
rfa)"(#0)->ust.ust_self[#1]")
; (get 'aref 'inline-unsafe))
-;(push '(((array fixnum) fixnum) fixnum #.(flags
rfa)"(#0)->fixa.fixa_self[#1]")
+;(pushn '(((array fixnum) fixnum) fixnum #.(flags
rfa)"(#0)->fixa.fixa_self[#1]")
; (get 'aref 'inline-unsafe))
-;(push '(((array unsigned-char) fixnum) fixnum #.(flags
rfa)"(#0)->ust.ust_self[#1]")
+;(pushn '(((array unsigned-char) fixnum) fixnum #.(flags
rfa)"(#0)->ust.ust_self[#1]")
; (get 'aref 'inline-unsafe))
-;(push '(((array signed-char) fixnum) fixnum #.(flags
rfa)"SIGNED_CHAR((#0)->ust.ust_self[#1])")
+;(pushn '(((array signed-char) fixnum) fixnum #.(flags
rfa)"SIGNED_CHAR((#0)->ust.ust_self[#1])")
; (get 'aref 'inline-unsafe))
-;(push '(((array unsigned-short) fixnum) fixnum #.(flags rfa)
+;(pushn '(((array unsigned-short) fixnum) fixnum #.(flags rfa)
; "((unsigned short *)(#0)->ust.ust_self)[#1]")
; (get 'aref 'inline-unsafe))
-;(push '(((array signed-short) fixnum) fixnum #.(flags rfa)"((short
*)(#0)->ust.ust_self)[#1]")
+;(pushn '(((array signed-short) fixnum) fixnum #.(flags rfa)"((short
*)(#0)->ust.ust_self)[#1]")
; (get 'aref 'inline-unsafe))
-;(push '(((array short-float) fixnum) short-float #.(flags
rfa)"(#0)->sfa.sfa_self[#1]")
+;(pushn '(((array short-float) fixnum) short-float #.(flags
rfa)"(#0)->sfa.sfa_self[#1]")
; (get 'aref 'inline-unsafe))
-;(push '(((array long-float) fixnum) long-float #.(flags
rfa)"(#0)->lfa.lfa_self[#1]")
+;(pushn '(((array long-float) fixnum) long-float #.(flags
rfa)"(#0)->lfa.lfa_self[#1]")
; (get 'aref 'inline-unsafe))
-;(push '((t t t) t #.(flags ans)
+;(pushn '((t t t) t #.(flags ans)
; "@0;aref(#0,fix(#1)*(#0)->a.a_dims[1]+fix(#2))")
; (get 'aref 'inline-unsafe))
-;(push '(((array t) fixnum fixnum) t #.(flags )
+;(pushn '(((array t) fixnum fixnum) t #.(flags )
; "@0;(#0)->a.a_self[(#1)*(#0)->a.a_dims[1]+#2]")
; (get 'aref 'inline-unsafe))
-;(push '(((array character) fixnum fixnum) character #.(flags rfa)
+;(pushn '(((array character) fixnum fixnum) character #.(flags rfa)
; "@0;(#0)->ust.ust_self[(#1)*(#0)->a.a_dims[1]+#2]")
; (get 'aref 'inline-unsafe))
-;(push '(((array fixnum) fixnum fixnum) fixnum #.(flags rfa)
+;(pushn '(((array fixnum) fixnum fixnum) fixnum #.(flags rfa)
; "@0;(#0)->fixa.fixa_self[(#1)*(#0)->a.a_dims[1]+#2]")
; (get 'aref 'inline-unsafe))
-;(push '(((array short-float) fixnum fixnum) short-float #.(flags rfa)
+;(pushn '(((array short-float) fixnum fixnum) short-float #.(flags rfa)
; "@0;(#0)->sfa.sfa_self[(#1)*(#0)->a.a_dims[1]+#2]")
; (get 'aref 'inline-unsafe))
-;(push '(((array long-float) fixnum fixnum) long-float #.(flags rfa)
+;(pushn '(((array long-float) fixnum fixnum) long-float #.(flags rfa)
; "@0;(#0)->lfa.lfa_self[(#1)*(#0)->a.a_dims[1]+#2]")
; (get 'aref 'inline-unsafe))
;(si::putprop 'aref 'aref-propagator 'type-propagator)
-;(push '((t *) t #.(flags rfba)aref-inline)
+;(pushn '((t *) t #.(flags rfba)aref-inline)
; (get 'aref 'inline-unsafe))
-;(push '(((array) *) t #.(flags rfba)aref-inline)
+;(pushn '(((array) *) t #.(flags rfba)aref-inline)
; (get 'aref 'inline-always))
;;ROW-MAJOR-AREF
;(si::putprop 'row-major-aref 'aref-propagator 'type-propagator)
-;(push '(nil nil #.(flags rfba)row-major-aref-inline)
+;(pushn '(nil nil #.(flags rfba)row-major-aref-inline)
; (get 'row-major-aref 'inline-unsafe))
;;CMP-AREF
(setf (symbol-function 'cmp-aref) (symbol-function 'row-major-aref))
(si::putprop 'cmp-aref 'aref-propagator 'type-propagator)
-(push '(cmp-aref-inline-types nil #.(flags itf) cmp-aref-inline)
+(pushn '(cmp-aref-inline-types nil #.(flags itf) cmp-aref-inline)
(get 'cmp-aref 'inline-always))
;;CMP-ASET
(setf (symbol-function 'cmp-aset) (symbol-function 'si::aset1))
(si::putprop 'cmp-aset 'aref-propagator 'type-propagator)
-(push '(cmp-aset-inline-types nil #.(flags itf) cmp-aset-inline)
+(pushn '(cmp-aset-inline-types nil #.(flags itf) cmp-aset-inline)
(get 'cmp-aset 'inline-always))
;;ARRAY-DIMENSION
-;(push '((t fixnum) fixnum #.(flags rfa)"@01;(type_of(#0)==t_array ?
(#0)->a.a_dims[(#1)] : (#0)->v.v_dim)")
+;(pushn '((t fixnum) fixnum #.(flags rfa)"@01;(type_of(#0)==t_array ?
(#0)->a.a_dims[(#1)] : (#0)->v.v_dim)")
; (get 'array-dimension 'inline-unsafe))
;;CMP-ARRAY-DIMENSION
(setf (symbol-function 'cmp-array-dimension) (symbol-function
'array-dimension))
-(push '(cmp-array-dimension-inline-types nil #.(flags itf)
cmp-array-dimension-inline)
+(pushn '(cmp-array-dimension-inline-types nil #.(flags itf)
cmp-array-dimension-inline)
(get 'cmp-array-dimension 'inline-always))
;;ARRAY-TOTAL-SIZE
- (push '((t) fixnum #.(flags rfa)"((#0)->st.st_dim)")
+ (pushn '((t) fixnum #.(flags rfa)"((#0)->st.st_dim)")
(get 'array-total-size 'inline-unsafe))
;;ARRAYP
- (push '((t) boolean #.(flags rfa)
+ (pushn '((t) boolean #.(flags rfa)
"@0;({enum type _tp=type_of(#0);_tp>=t_string && _tp<=t_array;})")
(get 'arrayp 'inline-always))
;;ATOM
- (push '((t) boolean #.(flags rfa)"atom(#0)")
+ (pushn '((t) boolean #.(flags rfa)"atom(#0)")
(get 'atom 'inline-always))
;;BIT-VECTOR-P
- (push '((t) boolean #.(flags rfa)"(type_of(#0)==t_bitvector)")
+ (pushn '((t) boolean #.(flags rfa)"(type_of(#0)==t_bitvector)")
(get 'bit-vector-p 'inline-always))
;;BOUNDP
- (push '((t) boolean #.(flags rfa)"(#0)->s.s_dbind!=OBJNULL")
+ (pushn '((t) boolean #.(flags rfa)"(#0)->s.s_dbind!=OBJNULL")
(get 'boundp 'inline-unsafe))
;;CAAAAR
- (push '((t) t #.(flags)"caaaar(#0)")
+ (pushn '((t) t #.(flags)"caaaar(#0)")
(get 'caaaar 'inline-safe))
-(push '((t) t #.(flags)"CMPcaaaar(#0)")
+(pushn '((t) t #.(flags)"CMPcaaaar(#0)")
(get 'caaaar 'inline-unsafe))
;;CAAADR
- (push '((t) t #.(flags)"caaadr(#0)")
+ (pushn '((t) t #.(flags)"caaadr(#0)")
(get 'caaadr 'inline-safe))
-(push '((t) t #.(flags)"CMPcaaadr(#0)")
+(pushn '((t) t #.(flags)"CMPcaaadr(#0)")
(get 'caaadr 'inline-unsafe))
;;CAAAR
- (push '((t) t #.(flags)"caaar(#0)")
+ (pushn '((t) t #.(flags)"caaar(#0)")
(get 'caaar 'inline-safe))
-(push '((t) t #.(flags)"CMPcaaar(#0)")
+(pushn '((t) t #.(flags)"CMPcaaar(#0)")
(get 'caaar 'inline-unsafe))
;;CAADAR
- (push '((t) t #.(flags)"caadar(#0)")
+ (pushn '((t) t #.(flags)"caadar(#0)")
(get 'caadar 'inline-safe))
-(push '((t) t #.(flags)"CMPcaadar(#0)")
+(pushn '((t) t #.(flags)"CMPcaadar(#0)")
(get 'caadar 'inline-unsafe))
;;CAADDR
- (push '((t) t #.(flags)"caaddr(#0)")
+ (pushn '((t) t #.(flags)"caaddr(#0)")
(get 'caaddr 'inline-safe))
-(push '((t) t #.(flags)"CMPcaaddr(#0)")
+(pushn '((t) t #.(flags)"CMPcaaddr(#0)")
(get 'caaddr 'inline-unsafe))
;;CAADR
- (push '((t) t #.(flags)"caadr(#0)")
+ (pushn '((t) t #.(flags)"caadr(#0)")
(get 'caadr 'inline-safe))
-(push '((t) t #.(flags)"CMPcaadr(#0)")
+(pushn '((t) t #.(flags)"CMPcaadr(#0)")
(get 'caadr 'inline-unsafe))
;;CAAR
- (push '((t) t #.(flags)"caar(#0)")
+ (pushn '((t) t #.(flags)"caar(#0)")
(get 'caar 'inline-safe))
-(push '((t) t #.(flags)"CMPcaar(#0)")
+(pushn '((t) t #.(flags)"CMPcaar(#0)")
(get 'caar 'inline-unsafe))
;;CADAAR
- (push '((t) t #.(flags)"cadaar(#0)")
+ (pushn '((t) t #.(flags)"cadaar(#0)")
(get 'cadaar 'inline-safe))
-(push '((t) t #.(flags)"CMPcadaar(#0)")
+(pushn '((t) t #.(flags)"CMPcadaar(#0)")
(get 'cadaar 'inline-unsafe))
;;CADADR
- (push '((t) t #.(flags)"cadadr(#0)")
+ (pushn '((t) t #.(flags)"cadadr(#0)")
(get 'cadadr 'inline-safe))
-(push '((t) t #.(flags)"CMPcadadr(#0)")
+(pushn '((t) t #.(flags)"CMPcadadr(#0)")
(get 'cadadr 'inline-unsafe))
;;CADAR
- (push '((t) t #.(flags)"cadar(#0)")
+ (pushn '((t) t #.(flags)"cadar(#0)")
(get 'cadar 'inline-safe))
-(push '((t) t #.(flags)"CMPcadar(#0)")
+(pushn '((t) t #.(flags)"CMPcadar(#0)")
(get 'cadar 'inline-unsafe))
;;CADDAR
- (push '((t) t #.(flags)"caddar(#0)")
+ (pushn '((t) t #.(flags)"caddar(#0)")
(get 'caddar 'inline-safe))
-(push '((t) t #.(flags)"CMPcaddar(#0)")
+(pushn '((t) t #.(flags)"CMPcaddar(#0)")
(get 'caddar 'inline-unsafe))
;;CADDDR
- (push '((t) t #.(flags)"cadddr(#0)")
+ (pushn '((t) t #.(flags)"cadddr(#0)")
(get 'cadddr 'inline-safe))
-(push '((t) t #.(flags)"CMPcadddr(#0)")
+(pushn '((t) t #.(flags)"CMPcadddr(#0)")
(get 'cadddr 'inline-unsafe))
;;CADDR
- (push '((t) t #.(flags)"caddr(#0)")
+ (pushn '((t) t #.(flags)"caddr(#0)")
(get 'caddr 'inline-safe))
-(push '((t) t #.(flags)"CMPcaddr(#0)")
+(pushn '((t) t #.(flags)"CMPcaddr(#0)")
(get 'caddr 'inline-unsafe))
;;CADR
- (push '((t) t #.(flags)"cadr(#0)")
+ (pushn '((t) t #.(flags)"cadr(#0)")
(get 'cadr 'inline-safe))
-(push '((t) t #.(flags)"CMPcadr(#0)")
+(pushn '((t) t #.(flags)"CMPcadr(#0)")
(get 'cadr 'inline-unsafe))
;;CAR
- (push '((t) t #.(flags)"car(#0)")
+ (pushn '((t) t #.(flags)"car(#0)")
(get 'car 'inline-safe))
-(push '((t) t #.(flags)"CMPcar(#0)")
+(pushn '((t) t #.(flags)"CMPcar(#0)")
(get 'car 'inline-unsafe))
;;CDAAAR
- (push '((t) t #.(flags)"cdaaar(#0)")
+ (pushn '((t) t #.(flags)"cdaaar(#0)")
(get 'cdaaar 'inline-safe))
-(push '((t) t #.(flags)"CMPcdaaar(#0)")
+(pushn '((t) t #.(flags)"CMPcdaaar(#0)")
(get 'cdaaar 'inline-unsafe))
;;CDAADR
- (push '((t) t #.(flags)"cdaadr(#0)")
+ (pushn '((t) t #.(flags)"cdaadr(#0)")
(get 'cdaadr 'inline-safe))
-(push '((t) t #.(flags)"CMPcdaadr(#0)")
+(pushn '((t) t #.(flags)"CMPcdaadr(#0)")
(get 'cdaadr 'inline-unsafe))
;;CDAAR
- (push '((t) t #.(flags)"cdaar(#0)")
+ (pushn '((t) t #.(flags)"cdaar(#0)")
(get 'cdaar 'inline-safe))
-(push '((t) t #.(flags)"CMPcdaar(#0)")
+(pushn '((t) t #.(flags)"CMPcdaar(#0)")
(get 'cdaar 'inline-unsafe))
;;CDADAR
- (push '((t) t #.(flags)"cdadar(#0)")
+ (pushn '((t) t #.(flags)"cdadar(#0)")
(get 'cdadar 'inline-safe))
-(push '((t) t #.(flags)"CMPcdadar(#0)")
+(pushn '((t) t #.(flags)"CMPcdadar(#0)")
(get 'cdadar 'inline-unsafe))
;;CDADDR
- (push '((t) t #.(flags)"cdaddr(#0)")
+ (pushn '((t) t #.(flags)"cdaddr(#0)")
(get 'cdaddr 'inline-safe))
-(push '((t) t #.(flags)"CMPcdaddr(#0)")
+(pushn '((t) t #.(flags)"CMPcdaddr(#0)")
(get 'cdaddr 'inline-unsafe))
;;CDADR
- (push '((t) t #.(flags)"cdadr(#0)")
+ (pushn '((t) t #.(flags)"cdadr(#0)")
(get 'cdadr 'inline-safe))
-(push '((t) t #.(flags)"CMPcdadr(#0)")
+(pushn '((t) t #.(flags)"CMPcdadr(#0)")
(get 'cdadr 'inline-unsafe))
;;CDAR
- (push '((t) t #.(flags)"cdar(#0)")
+ (pushn '((t) t #.(flags)"cdar(#0)")
(get 'cdar 'inline-safe))
-(push '((t) t #.(flags)"CMPcdar(#0)")
+(pushn '((t) t #.(flags)"CMPcdar(#0)")
(get 'cdar 'inline-unsafe))
;;CDDAAR
- (push '((t) t #.(flags)"cddaar(#0)")
+ (pushn '((t) t #.(flags)"cddaar(#0)")
(get 'cddaar 'inline-safe))
-(push '((t) t #.(flags)"CMPcddaar(#0)")
+(pushn '((t) t #.(flags)"CMPcddaar(#0)")
(get 'cddaar 'inline-unsafe))
;;CDDADR
- (push '((t) t #.(flags)"cddadr(#0)")
+ (pushn '((t) t #.(flags)"cddadr(#0)")
(get 'cddadr 'inline-safe))
-(push '((t) t #.(flags)"CMPcddadr(#0)")
+(pushn '((t) t #.(flags)"CMPcddadr(#0)")
(get 'cddadr 'inline-unsafe))
;;CDDAR
- (push '((t) t #.(flags)"cddar(#0)")
+ (pushn '((t) t #.(flags)"cddar(#0)")
(get 'cddar 'inline-safe))
-(push '((t) t #.(flags)"CMPcddar(#0)")
+(pushn '((t) t #.(flags)"CMPcddar(#0)")
(get 'cddar 'inline-unsafe))
;;CDDDAR
- (push '((t) t #.(flags)"cdddar(#0)")
+ (pushn '((t) t #.(flags)"cdddar(#0)")
(get 'cdddar 'inline-safe))
-(push '((t) t #.(flags)"CMPcdddar(#0)")
+(pushn '((t) t #.(flags)"CMPcdddar(#0)")
(get 'cdddar 'inline-unsafe))
;;CDDDDR
- (push '((t) t #.(flags)"cddddr(#0)")
+ (pushn '((t) t #.(flags)"cddddr(#0)")
(get 'cddddr 'inline-safe))
-(push '((t) t #.(flags)"CMPcddddr(#0)")
+(pushn '((t) t #.(flags)"CMPcddddr(#0)")
(get 'cddddr 'inline-unsafe))
;;CDDDR
- (push '((t) t #.(flags)"cdddr(#0)")
+ (pushn '((t) t #.(flags)"cdddr(#0)")
(get 'cdddr 'inline-safe))
-(push '((t) t #.(flags)"CMPcdddr(#0)")
+(pushn '((t) t #.(flags)"CMPcdddr(#0)")
(get 'cdddr 'inline-unsafe))
;;CDDR
- (push '((t) t #.(flags)"cddr(#0)")
+ (pushn '((t) t #.(flags)"cddr(#0)")
(get 'cddr 'inline-safe))
-(push '((t) t #.(flags)"CMPcddr(#0)")
+(pushn '((t) t #.(flags)"CMPcddr(#0)")
(get 'cddr 'inline-unsafe))
;;CDR
- (push '((t) t #.(flags)"cdr(#0)")
+ (pushn '((t) t #.(flags)"cdr(#0)")
(get 'cdr 'inline-safe))
-(push '((t) t #.(flags)"CMPcdr(#0)")
+(pushn '((t) t #.(flags)"CMPcdr(#0)")
(get 'cdr 'inline-unsafe))
;;CHAR
- (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))")
+ (pushn '((t t) t #.(flags ans)"elt(#0,fixint(#1))")
(get 'char 'inline-always))
-(push '((t fixnum) t #.(flags ans)"elt(#0,#1)")
+(pushn '((t fixnum) t #.(flags ans)"elt(#0,#1)")
(get 'char 'inline-always))
-(push '((t t) t #.(flags)"code_char((#0)->ust.ust_self[fix(#1)])")
+(pushn '((t t) t #.(flags)"code_char((#0)->ust.ust_self[fix(#1)])")
(get 'char 'inline-unsafe))
-(push '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]")
+(pushn '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]")
(get 'char 'inline-unsafe))
;;CHAR-CODE
- (push '((character) fixnum #.(flags rfa)"(#0)")
+ (pushn '((character) fixnum #.(flags rfa)"(#0)")
(get 'char-code 'inline-always))
;;CHAR/=
-(push '((t t) boolean #.(flags rfa)"!eql(#0,#1)")
+(pushn '((t t) boolean #.(flags rfa)"!eql(#0,#1)")
(get 'char/= 'inline-unsafe))
-(push '((t t) boolean #.(flags rfa)"char_code(#0)!=char_code(#1)")
+(pushn '((t t) boolean #.(flags rfa)"char_code(#0)!=char_code(#1)")
(get 'char/= 'inline-unsafe))
-(push '((character character) boolean #.(flags rfa)"(#0)!=(#1)")
+(pushn '((character character) boolean #.(flags rfa)"(#0)!=(#1)")
(get 'char/= 'inline-unsafe))
;;CHAR<
- (push '((character character) boolean #.(flags rfa)"(#0)<(#1)")
+ (pushn '((character character) boolean #.(flags rfa)"(#0)<(#1)")
(get 'char< 'inline-always))
;;CHAR<=
- (push '((character character) boolean #.(flags rfa)"(#0)<=(#1)")
+ (pushn '((character character) boolean #.(flags rfa)"(#0)<=(#1)")
(get 'char<= 'inline-always))
;;CHAR=
- (push '((t t) boolean #.(flags rfa)"eql(#0,#1)")
+ (pushn '((t t) boolean #.(flags rfa)"eql(#0,#1)")
(get 'char= 'inline-unsafe))
-(push '((t t) boolean #.(flags rfa)"char_code(#0)==char_code(#1)")
+(pushn '((t t) boolean #.(flags rfa)"char_code(#0)==char_code(#1)")
(get 'char= 'inline-unsafe))
-(push '((character character) boolean #.(flags rfa)"(#0)==(#1)")
+(pushn '((character character) boolean #.(flags rfa)"(#0)==(#1)")
(get 'char= 'inline-unsafe))
;;CHAR>
- (push '((character character) boolean #.(flags rfa)"(#0)>(#1)")
+ (pushn '((character character) boolean #.(flags rfa)"(#0)>(#1)")
(get 'char> 'inline-always))
;;CHAR>=
- (push '((character character) boolean #.(flags rfa)"(#0)>=(#1)")
+ (pushn '((character character) boolean #.(flags rfa)"(#0)>=(#1)")
(get 'char>= 'inline-always))
;;CHARACTERP
- (push '((t) boolean #.(flags rfa)"type_of(#0)==t_character")
+ (pushn '((t) boolean #.(flags rfa)"type_of(#0)==t_character")
(get 'characterp 'inline-always))
;;CODE-CHAR
- (push '((fixnum) character #.(flags)"(#0)")
+ (pushn '((fixnum) character #.(flags)"(#0)")
(get 'code-char 'inline-always))
;;CONS
- (push '((t t) t #.(flags ans) CONS-INLINE)
+ (pushn '((t t) t #.(flags ans) CONS-INLINE)
(get 'cons 'inline-always))
-;(push '((t t) :dynamic-extent #.(flags ans)"ON_STACK_CONS(#0,#1)")
+;(pushn '((t t) :dynamic-extent #.(flags ans)"ON_STACK_CONS(#0,#1)")
; (get 'cons 'inline-always))
;;CONSP
- (push '((t) boolean #.(flags rfa)"consp(#0)")
+ (pushn '((t) boolean #.(flags rfa)"consp(#0)")
(get 'consp 'inline-always))
;;COS
- (push '((long-float) long-float #.(flags rfa)"cos(#0)")
+ (pushn '((long-float) long-float #.(flags rfa)"cos(#0)")
(get 'cos 'inline-always))
;;DIGIT-CHAR-P
- (push '((character) boolean #.(flags rfa)"@0; ((#0) <= '9' && (#0) >= '0')")
+ (pushn '((character) boolean #.(flags rfa)"@0; ((#0) <= '9' && (#0) >= '0')")
(get 'digit-char-p 'inline-always))
;;ELT
- (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))")
+ (pushn '((t t) t #.(flags ans)"elt(#0,fixint(#1))")
(get 'elt 'inline-always))
-(push '((t fixnum) t #.(flags ans)"elt(#0,#1)")
+(pushn '((t fixnum) t #.(flags ans)"elt(#0,#1)")
(get 'elt 'inline-always))
-(push '((t t) t #.(flags ans)"elt(#0,fix(#1))")
+(pushn '((t t) t #.(flags ans)"elt(#0,fix(#1))")
(get 'elt 'inline-unsafe))
;;ENDP
- (push '((t) boolean #.(flags rfa)"endp(#0)")
+ (pushn '((t) boolean #.(flags rfa)"endp(#0)")
(get 'endp 'inline-safe))
-(push '((t) boolean #.(flags rfa)"(#0)==Cnil")
+(pushn '((t) boolean #.(flags rfa)"(#0)==Cnil")
(get 'endp 'inline-unsafe))
;;EQ
- (push '((t t) boolean #.(flags rfa)"(#0)==(#1)")
+ (pushn '((t t) boolean #.(flags rfa)"(#0)==(#1)")
(get 'eq 'inline-always))
-;(push '((fixnum fixnum) boolean #.(flags rfa)"0")
+;(pushn '((fixnum fixnum) boolean #.(flags rfa)"0")
; (get 'eq 'inline-always))
;;EQL
- (push '((t t) boolean #.(flags rfa)"eql(#0,#1)")
+ (pushn '((t t) boolean #.(flags rfa)"eql(#0,#1)")
(get 'eql 'inline-always))
-(push '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)==(#1)")
+(pushn '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)==(#1)")
(get 'eql 'inline-always))
-(push '((character character) boolean #.(flags rfa)"(#0)==(#1)")
+(pushn '((character character) boolean #.(flags rfa)"(#0)==(#1)")
(get 'eql 'inline-always))
;;FIXME -- floats?
;;EQUAL
- (push '((t t) boolean #.(flags rfa)"equal(#0,#1)")
+ (pushn '((t t) boolean #.(flags rfa)"equal(#0,#1)")
(get 'equal 'inline-always))
-(push '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)==(#1)")
+(pushn '((fixnum-float fixnum-float) boolean #.(flags rfa)"(#0)==(#1)")
(get 'equal 'inline-always))
-(push '((character character) boolean #.(flags rfa)"(#0)==(#1)")
+(pushn '((character character) boolean #.(flags rfa)"(#0)==(#1)")
(get 'equal 'inline-always))
;;EQUALP
- (push '((t t) boolean #.(flags rfa)"equalp(#0,#1)")
+ (pushn '((t t) boolean #.(flags rfa)"equalp(#0,#1)")
(get 'equalp 'inline-always))
- (push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)")
+ (pushn '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)")
(get 'equalp 'inline-always))
- (push '((short-float short-float) boolean #.(flags rfa)"(#0)==(#1)")
+ (pushn '((short-float short-float) boolean #.(flags rfa)"(#0)==(#1)")
(get 'equalp 'inline-always))
- (push '((long-float long-float) boolean #.(flags rfa)"(#0)==(#1)")
+ (pushn '((long-float long-float) boolean #.(flags rfa)"(#0)==(#1)")
(get 'equalp 'inline-always))
- (push '((character character) boolean #.(flags rfa)"(#0)==(#1)")
+ (pushn '((character character) boolean #.(flags rfa)"(#0)==(#1)")
(get 'equalp 'inline-always))
;;EXPT
- (push '((t t) t #.(flags ans)"number_expt(#0,#1)")
+ (pushn '((t t) t #.(flags ans)"number_expt(#0,#1)")
(get 'expt 'inline-always))
-(push '((fixnum fixnum) fixnum #.(flags)(LAMBDA (LOC1 LOC2)
+(pushn '((fixnum fixnum) fixnum #.(flags)(LAMBDA (LOC1 LOC2)
(IF
(AND (CONSP LOC1)
(EQ (CAR LOC1) 'FIXNUM-LOC)
@@ -842,293 +848,293 @@
;;FILL-POINTER
- (push '((t) seqind #.(flags rfa)"((#0)->v.v_fillp)")
+ (pushn '((t) seqind #.(flags rfa)"((#0)->v.v_fillp)")
(get 'fill-pointer 'inline-unsafe))
- (push '((vector) seqind #.(flags rfa)"((#0)->v.v_fillp)")
+ (pushn '((vector) seqind #.(flags rfa)"((#0)->v.v_fillp)")
(get 'fill-pointer 'inline-always))
;;ARRAY-HAS-FILL-POINTER-P
- (push '((t) boolean #.(flags rfa)"((#0)->v.v_hasfillp)")
+ (pushn '((t) boolean #.(flags rfa)"((#0)->v.v_hasfillp)")
(get 'array-has-fill-pointer-p 'inline-unsafe))
- (push '((vector) boolean #.(flags rfa)"((#0)->v.v_hasfillp)")
+ (pushn '((vector) boolean #.(flags rfa)"((#0)->v.v_hasfillp)")
(get 'array-has-fill-pointer-p 'inline-always))
;;FIRST
- (push '((t) t #.(flags)"car(#0)")
+ (pushn '((t) t #.(flags)"car(#0)")
(get 'first 'inline-safe))
-(push '((t) t #.(flags)"CMPcar(#0)")
+(pushn '((t) t #.(flags)"CMPcar(#0)")
(get 'first 'inline-unsafe))
;;FLOAT
- (push '((fixnum-float) long-float #.(flags)"((longfloat)(#0))")
+ (pushn '((fixnum-float) long-float #.(flags)"((longfloat)(#0))")
(get 'float 'inline-always))
-(push '((fixnum-float) short-float #.(flags)"((shortfloat)(#0))")
+(pushn '((fixnum-float) short-float #.(flags)"((shortfloat)(#0))")
(get 'float 'inline-always))
;;FLOATP
- (push '((t) boolean #.(flags rfa)
+ (pushn '((t) boolean #.(flags rfa)
"@0;type_of(#0)==t_shortfloat||type_of(#0)==t_longfloat")
(get 'floatp 'inline-always))
;;FLOOR
-; (push '((fixnum fixnum) fixnum #.(flags rfa)
+; (pushn '((fixnum fixnum) fixnum #.(flags rfa)
; "@01;(#0>=0&&(#1)>0?(#0)/(#1):ifloor(#0,#1))")
; (get 'floor 'inline-always))
;(si::putprop 'floor 'floor-propagator 'type-propagator)
-(push '((fixnum fixnum) (values fixnum fixnum) #.(flags rfa set)
+(pushn '((fixnum fixnum) (values fixnum fixnum) #.(flags rfa set)
"@01;({fixnum _t=(#0)/(#1);_t=((#0)<=0 && (#1)<=0) || ((#0)>=0 &&
(#1)>=0) || ((#1)*_t==(#0)) ? _t : _t-1;@1((#0)-_t*(#1))@ _t;})")
(get 'floor 'inline-always))
;;CEILING
;(si::putprop 'ceiling 'floor-propagator 'type-propagator)
-(push '((fixnum fixnum) (values fixnum fixnum) #.(flags rfa set)
+(pushn '((fixnum fixnum) (values fixnum fixnum) #.(flags rfa set)
"@01;({fixnum _t=(#0)/(#1);_t=((#0)<=0 && (#1)>=0) || ((#0)>=0 &&
(#1)<=0) || ((#1)*_t==(#0)) ? _t : _t+1;@1((#0)-_t*(#1))@ _t;})")
(get 'ceiling 'inline-always))
;;FOURTH
- (push '((t) t #.(flags)"cadddr(#0)")
+ (pushn '((t) t #.(flags)"cadddr(#0)")
(get 'fourth 'inline-safe))
-(push '((t) t #.(flags)"CMPcadddr(#0)")
+(pushn '((t) t #.(flags)"CMPcadddr(#0)")
(get 'fourth 'inline-unsafe))
;;GET
- (push '((t t t) t #.(flags)"get(#0,#1,#2)")
+ (pushn '((t t t) t #.(flags)"get(#0,#1,#2)")
(get 'get 'inline-always))
-(push '((t t) t #.(flags)"get(#0,#1,Cnil)")
+(pushn '((t t) t #.(flags)"get(#0,#1,Cnil)")
(get 'get 'inline-always))
;;INTEGERP
- (push '((t) boolean #.(flags rfa)
+ (pushn '((t) boolean #.(flags rfa)
"@0;({enum type _tp=type_of(#0);_tp==t_fixnum||_tp==t_bignum;})")
(get 'integerp 'inline-always))
-(push '((fixnum) boolean #.(flags rfa)"1")
+(pushn '((fixnum) boolean #.(flags rfa)"1")
(get 'integerp 'inline-always))
;;KEYWORDP
- (push '((t) boolean #.(flags rfa)
+ (pushn '((t) boolean #.(flags rfa)
"@0;(type_of(#0)==t_symbol&&(#0)->s.s_hpack==keyword_package)")
(get 'keywordp 'inline-always))
;;ADDRESS
- (push '((t) fixnum #.(flags rfa)"((fixnum)(#0))")
+ (pushn '((t) fixnum #.(flags rfa)"((fixnum)(#0))")
(get 'si::address 'inline-always))
;;NANI
- (push '((fixnum) t #.(flags rfa)"((object)(#0))")
+ (pushn '((fixnum) t #.(flags rfa)"((object)(#0))")
(get 'si::nani 'inline-always))
;;LENGTH
- (push '((t) seqind #.(flags rfa set)"length(#0)")
+ (pushn '((t) seqind #.(flags rfa set)"length(#0)")
(get 'length 'inline-always))
-(push '((vector) seqind #.(flags rfa)"(#0)->v.v_fillp")
+(pushn '((vector) seqind #.(flags rfa)"(#0)->v.v_fillp")
(get 'length 'inline-unsafe))
;;CMP-VEC-LENGTH
-(push '((t) seqind #.(flags rfa)"(#0)->v.v_fillp")
+(pushn '((t) seqind #.(flags rfa)"(#0)->v.v_fillp")
(get 'cmp-vec-length 'inline-always))
-;(push '(((array t)) seqind #.(flags rfa)"(#0)->v.v_fillp")
+;(pushn '(((array t)) seqind #.(flags rfa)"(#0)->v.v_fillp")
; (get 'length 'inline-unsafe))
-;(push '(((array fixnum)) seqind #.(flags rfa)"(#0)->v.v_fillp")
+;(pushn '(((array fixnum)) seqind #.(flags rfa)"(#0)->v.v_fillp")
; (get 'length 'inline-unsafe))
-;(push '((string) seqind #.(flags rfa)"(#0)->v.v_fillp")
+;(pushn '((string) seqind #.(flags rfa)"(#0)->v.v_fillp")
; (get 'length 'inline-unsafe))
;;LIST
- (push '(nil t #.(flags)"Cnil")
+ (pushn '(nil t #.(flags)"Cnil")
(get 'list 'inline-always))
-(push '((t) t #.(flags ans)"make_cons(#0,Cnil)")
+(pushn '((t) t #.(flags ans)"make_cons(#0,Cnil)")
(get 'list 'inline-always))
-(push '((t t) t #.(flags ans)LIST-INLINE)
+(pushn '((t t) t #.(flags ans)LIST-INLINE)
(get 'list 'inline-always))
-(push '((t t t) t #.(flags ans)LIST-INLINE)
+(pushn '((t t t) t #.(flags ans)LIST-INLINE)
(get 'list 'inline-always))
-(push '((t t t t) t #.(flags ans)LIST-INLINE)
+(pushn '((t t t t) t #.(flags ans)LIST-INLINE)
(get 'list 'inline-always))
-(push '((t t t t t) t #.(flags ans)LIST-INLINE)
+(pushn '((t t t t t) t #.(flags ans)LIST-INLINE)
(get 'list 'inline-always))
-(push '((t t t t t t) t #.(flags ans)LIST-INLINE)
+(pushn '((t t t t t t) t #.(flags ans)LIST-INLINE)
(get 'list 'inline-always))
-(push '((t t t t t t t) t #.(flags ans)LIST-INLINE)
+(pushn '((t t t t t t t) t #.(flags ans)LIST-INLINE)
(get 'list 'inline-always))
-(push '((t t t t t t t t) t #.(flags ans)LIST-INLINE)
+(pushn '((t t t t t t t t) t #.(flags ans)LIST-INLINE)
(get 'list 'inline-always))
-(push '((t t t t t t t t t) t #.(flags ans)LIST-INLINE)
+(pushn '((t t t t t t t t t) t #.(flags ans)LIST-INLINE)
(get 'list 'inline-always))
-(push '((t t t t t t t t t t) t #.(flags ans)LIST-INLINE)
+(pushn '((t t t t t t t t t t) t #.(flags ans)LIST-INLINE)
(get 'list 'inline-always))
;;LIST*
- (push '((t) t #.(flags)"(#0)")
+ (pushn '((t) t #.(flags)"(#0)")
(get 'list* 'inline-always))
-(push '((t t) t #.(flags ans)"make_cons(#0,#1)")
+(pushn '((t t) t #.(flags ans)"make_cons(#0,#1)")
(get 'list* 'inline-always))
-(push '((t t t) t #.(flags ans)LIST*-INLINE)
+(pushn '((t t t) t #.(flags ans)LIST*-INLINE)
(get 'list* 'inline-always))
-(push '((t t t t) t #.(flags ans)LIST*-INLINE)
+(pushn '((t t t t) t #.(flags ans)LIST*-INLINE)
(get 'list* 'inline-always))
-(push '((t t t t t) t #.(flags ans)LIST*-INLINE)
+(pushn '((t t t t t) t #.(flags ans)LIST*-INLINE)
(get 'list* 'inline-always))
-(push '((t t t t t t) t #.(flags ans)LIST*-INLINE)
+(pushn '((t t t t t t) t #.(flags ans)LIST*-INLINE)
(get 'list* 'inline-always))
-(push '((t t t t t t t) t #.(flags ans)LIST*-INLINE)
+(pushn '((t t t t t t t) t #.(flags ans)LIST*-INLINE)
(get 'list* 'inline-always))
-(push '((t t t t t t t t) t #.(flags ans)LIST*-INLINE)
+(pushn '((t t t t t t t t) t #.(flags ans)LIST*-INLINE)
(get 'list* 'inline-always))
-(push '((t t t t t t t t t) t #.(flags ans)LIST*-INLINE)
+(pushn '((t t t t t t t t t) t #.(flags ans)LIST*-INLINE)
(get 'list* 'inline-always))
-(push '((t t t t t t t t t t) t #.(flags ans)LIST*-INLINE)
+(pushn '((t t t t t t t t t t) t #.(flags ans)LIST*-INLINE)
(get 'list* 'inline-always))
;;LISTP
- (push '((t) boolean #.(flags rfa)"listp(#0)")
+ (pushn '((t) boolean #.(flags rfa)"listp(#0)")
(get 'listp 'inline-always))
;;LOGAND
- (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) & (#1))")
+ (pushn '((fixnum fixnum) fixnum #.(flags rfa)"((#0) & (#1))")
(get 'logand 'inline-always))
;;LOGANDC1
- (push '((fixnum fixnum) fixnum #.(flags rfa)"(~(#0) & (#1))")
+ (pushn '((fixnum fixnum) fixnum #.(flags rfa)"(~(#0) & (#1))")
(get 'logandc1 'inline-always))
;;LOGANDC2
- (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) & ~(#1))")
+ (pushn '((fixnum fixnum) fixnum #.(flags rfa)"((#0) & ~(#1))")
(get 'logandc2 'inline-always))
;;LOGIOR
- (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) | (#1))")
+ (pushn '((fixnum fixnum) fixnum #.(flags rfa)"((#0) | (#1))")
(get 'logior 'inline-always))
;;LOGXOR
- (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) ^ (#1))")
+ (pushn '((fixnum fixnum) fixnum #.(flags rfa)"((#0) ^ (#1))")
(get 'logxor 'inline-always))
;;LOGNOT
- (push '((fixnum) fixnum #.(flags rfa)"(~(#0))")
+ (pushn '((fixnum) fixnum #.(flags rfa)"(~(#0))")
(get 'lognot 'inline-always))
;;MAKE-LIST
- (push '((fixnum) t #.(flags ans) MAKE-LIST-INLINE)
+ (pushn '((fixnum) t #.(flags ans) MAKE-LIST-INLINE)
(get 'make-list 'inline-always))
;;INTEGER-LENGTH
-(push '((fixnum) fixnum #.(flags rfa set)
+(pushn '((fixnum) fixnum #.(flags rfa set)
#.(format nil "({register fixnum _x=#0,_t=~s;for (;_t>=0 &&
!((_x>>_t)&1);_t--);_t+1;})" (integer-length most-positive-fixnum)))
(get 'integer-length 'inline-always))
;;MAX
-(push '((t t) t #.(flags set)"@01;({register int _r=number_compare(#0,#1);
fixnum_float_contagion(_r>=0 ? #0 : #1,_r>=0 ? #1 : #0);})")
+(pushn '((t t) t #.(flags set)"@01;({register int _r=number_compare(#0,#1);
fixnum_float_contagion(_r>=0 ? #0 : #1,_r>=0 ? #1 : #0);})")
(get 'max 'inline-always))
-(push '((fixnum-float fixnum-float) long-float #.(flags
set)"@01;((double)((#0)>=(#1)?(#0):#1))")
+(pushn '((fixnum-float fixnum-float) long-float #.(flags
set)"@01;((double)((#0)>=(#1)?(#0):#1))")
(get 'max 'inline-always))
-(push '((fixnum-float fixnum-float) short-float #.(flags
set)"@01;((float)((#0)>=(#1)?(#0):#1))")
+(pushn '((fixnum-float fixnum-float) short-float #.(flags
set)"@01;((float)((#0)>=(#1)?(#0):#1))")
(get 'max 'inline-always))
-(push '((fixnum-float fixnum-float) fixnum #.(flags
set)"@01;((fixnum)((#0)>=(#1)?(#0):#1))")
+(pushn '((fixnum-float fixnum-float) fixnum #.(flags
set)"@01;((fixnum)((#0)>=(#1)?(#0):#1))")
(get 'max 'inline-always))
;;MIN
-(push '((t t) t #.(flags set)"@01;({register int _r=number_compare(#0,#1);
fixnum_float_contagion(_r<=0 ? #0 : #1,_r<=0 ? #1 : #0);})")
+(pushn '((t t) t #.(flags set)"@01;({register int _r=number_compare(#0,#1);
fixnum_float_contagion(_r<=0 ? #0 : #1,_r<=0 ? #1 : #0);})")
(get 'min 'inline-always))
-(push '((fixnum-float fixnum-float) long-float #.(flags
set)"@01;((double)((#0)<=(#1)?(#0):#1))")
+(pushn '((fixnum-float fixnum-float) long-float #.(flags
set)"@01;((double)((#0)<=(#1)?(#0):#1))")
(get 'min 'inline-always))
-(push '((fixnum-float fixnum-float) short-float #.(flags
set)"@01;((float)((#0)<=(#1)?(#0):#1))")
+(pushn '((fixnum-float fixnum-float) short-float #.(flags
set)"@01;((float)((#0)<=(#1)?(#0):#1))")
(get 'min 'inline-always))
-(push '((fixnum-float fixnum-float) fixnum #.(flags
set)"@01;((fixnum)((#0)<=(#1)?(#0):#1))")
+(pushn '((fixnum-float fixnum-float) fixnum #.(flags
set)"@01;((fixnum)((#0)<=(#1)?(#0):#1))")
(get 'min 'inline-always))
;;MINUSP
- (push '((t) boolean #.(flags rfa)"number_compare(small_fixnum(0),#0)>0")
+ (pushn '((t) boolean #.(flags rfa)"number_compare(small_fixnum(0),#0)>0")
(get 'minusp 'inline-always))
- (push '((fixnum-float) boolean #.(flags rfa)"(#0)<0")
+ (pushn '((fixnum-float) boolean #.(flags rfa)"(#0)<0")
(get 'minusp 'inline-always))
;;MOD
-; (push '((fixnum fixnum) fixnum #.(flags
rfa)"@01;(#0>=0&&(#1)>0?(#0)%(#1):imod(#0,#1))")
+; (pushn '((fixnum fixnum) fixnum #.(flags
rfa)"@01;(#0>=0&&(#1)>0?(#0)%(#1):imod(#0,#1))")
; (get 'mod 'inline-always))
- (push '((fixnum fixnum) fixnum #.(flags rfa set)"@01;({register fixnum
_t=(#0)%(#1);((#1)<0 && _t<=0) || ((#1)>0 && _t>=0) ? _t : _t + (#1);})")
+ (pushn '((fixnum fixnum) fixnum #.(flags rfa set)"@01;({register fixnum
_t=(#0)%(#1);((#1)<0 && _t<=0) || ((#1)>0 && _t>=0) ? _t : _t + (#1);})")
(get 'mod 'inline-always))
;;NCONC
- (push '((t t) t #.(flags set)"nconc(#0,#1)")
+ (pushn '((t t) t #.(flags set)"nconc(#0,#1)")
(get 'nconc 'inline-always))
;;NOT
- (push '((t) boolean #.(flags rfa)"(#0)==Cnil")
+ (pushn '((t) boolean #.(flags rfa)"(#0)==Cnil")
(get 'not 'inline-always))
;;NREVERSE
- (push '((t) t #.(flags ans set)"nreverse(#0)")
+ (pushn '((t) t #.(flags ans set)"nreverse(#0)")
(get 'nreverse 'inline-always))
;;CMP-NTHCDR
-(push '((seqind proper-list) proper-list #.(flags rfa)"({register fixnum
_i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})")
+(pushn '((seqind proper-list) proper-list #.(flags rfa)"({register fixnum
_i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})")
(get 'cmp-nthcdr 'inline-always))
-(push '(((and (integer 0) (not seqind)) proper-list) null #.(flags rfa)"Cnil")
+(pushn '(((and (integer 0) (not seqind)) proper-list) null #.(flags rfa)"Cnil")
(get 'cmp-nthcdr 'inline-always))
-(push '((seqind t) proper-list #.(flags rfa)"({register fixnum _i=#0;register
object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})")
+(pushn '((seqind t) proper-list #.(flags rfa)"({register fixnum _i=#0;register
object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})")
(get 'cmp-nthcdr 'inline-unsafe))
-(push '(((not seqind) proper-list) null #.(flags rfa)"Cnil")
+(pushn '(((not seqind) proper-list) null #.(flags rfa)"Cnil")
(get 'cmp-nthcdr 'inline-unsafe))
;;NULL
- (push '((t) boolean #.(flags rfa)"(#0)==Cnil")
+ (pushn '((t) boolean #.(flags rfa)"(#0)==Cnil")
(get 'null 'inline-always))
;;NUMBERP
- (push '((t) boolean #.(flags rfa)"@0;numberp(#0)")
+ (pushn '((t) boolean #.(flags rfa)"@0;numberp(#0)")
(get 'numberp 'inline-always))
;;EQL-IS-EQ
- (push '((t) boolean #.(flags rfa)"@0;eql_is_eq(#0)")
+ (pushn '((t) boolean #.(flags rfa)"@0;eql_is_eq(#0)")
(get 'eql-is-eq 'inline-always))
- (push '((fixnum) boolean #.(flags rfa)"@0;(is_imm_fix(#0))")
+ (pushn '((fixnum) boolean #.(flags rfa)"@0;(is_imm_fix(#0))")
(get 'eql-is-eq 'inline-always))
;;EQUAL-IS-EQ
- (push '((t) boolean #.(flags rfa)"@0;equal_is_eq(#0)")
+ (pushn '((t) boolean #.(flags rfa)"@0;equal_is_eq(#0)")
(get 'equal-is-eq 'inline-always))
- (push '((fixnum) boolean #.(flags rfa)"@0;(is_imm_fix(#0))")
+ (pushn '((fixnum) boolean #.(flags rfa)"@0;(is_imm_fix(#0))")
(get 'equal-is-eq 'inline-always))
;;EQUALP-IS-EQ
- (push '((t) boolean #.(flags rfa)"@0;equalp_is_eq(#0)")
+ (pushn '((t) boolean #.(flags rfa)"@0;equalp_is_eq(#0)")
(get 'equalp-is-eq 'inline-always))
;;PLUSP
- (push '((t) boolean #.(flags rfa)"number_compare(small_fixnum(0),#0)<0")
+ (pushn '((t) boolean #.(flags rfa)"number_compare(small_fixnum(0),#0)<0")
(get 'plusp 'inline-always))
-(push '((fixnum-float) boolean #.(flags rfa)"(#0)>0")
+(pushn '((fixnum-float) boolean #.(flags rfa)"(#0)>0")
(get 'plusp 'inline-always))
;;PRIN1
- (push '((t t) t #.(flags set)"prin1(#0,#1)")
+ (pushn '((t t) t #.(flags set)"prin1(#0,#1)")
(get 'prin1 'inline-always))
-(push '((t) t #.(flags set)"prin1(#0,Cnil)")
+(pushn '((t) t #.(flags set)"prin1(#0,Cnil)")
(get 'prin1 'inline-always))
;;PRINC
- (push '((t t) t #.(flags set)"princ(#0,#1)")
+ (pushn '((t t) t #.(flags set)"princ(#0,#1)")
(get 'princ 'inline-always))
-(push '((t) t #.(flags set)"princ(#0,Cnil)")
+(pushn '((t) t #.(flags set)"princ(#0,Cnil)")
(get 'princ 'inline-always))
;;PRINT
- (push '((t t) t #.(flags set)"print(#0,#1)")
+ (pushn '((t t) t #.(flags set)"print(#0,#1)")
(get 'print 'inline-always))
-(push '((t) t #.(flags set)"print(#0,Cnil)")
+(pushn '((t) t #.(flags set)"print(#0,Cnil)")
(get 'print 'inline-always))
;;PROBE-FILE
- (push '((t) boolean #.(flags)"(file_exists(#0))")
+ (pushn '((t) boolean #.(flags)"(file_exists(#0))")
(get 'probe-file 'inline-always))
;;RATIOP
-(push '((t) boolean #.(flags rfa) "type_of(#0)==t_ratio")
+(pushn '((t) boolean #.(flags rfa) "type_of(#0)==t_ratio")
(get 'ratiop 'inline-always))
;;REM
@@ -1136,104 +1142,104 @@
#+
TRUNCATE_USE_C
-(push '((fixnum fixnum) fixnum #.(flags rfa)"(#0)%(#1)")
+(pushn '((fixnum fixnum) fixnum #.(flags rfa)"(#0)%(#1)")
(get 'rem 'inline-always))
;;REMPROP
- (push '((t t) t #.(flags set)"remprop(#0,#1)")
+ (pushn '((t t) t #.(flags set)"remprop(#0,#1)")
(get 'remprop 'inline-always))
;;REST
- (push '((t) t #.(flags)"cdr(#0)")
+ (pushn '((t) t #.(flags)"cdr(#0)")
(get 'rest 'inline-safe))
-(push '((t) t #.(flags)"CMPcdr(#0)")
+(pushn '((t) t #.(flags)"CMPcdr(#0)")
(get 'rest 'inline-unsafe))
;;REVERSE
- (push '((t) t #.(flags ans)"reverse(#0)")
+ (pushn '((t) t #.(flags ans)"reverse(#0)")
(get 'reverse 'inline-always))
;;SCHAR
- (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))")
+ (pushn '((t t) t #.(flags ans)"elt(#0,fixint(#1))")
(get 'schar 'inline-always))
-(push '((t fixnum) t #.(flags ans)"elt(#0,#1)")
+(pushn '((t fixnum) t #.(flags ans)"elt(#0,#1)")
(get 'schar 'inline-always))
-(push '((t t) t #.(flags rfa)"code_char((#0)->ust.ust_self[fix(#1)])")
+(pushn '((t t) t #.(flags rfa)"code_char((#0)->ust.ust_self[fix(#1)])")
(get 'schar 'inline-unsafe))
-(push '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]")
+(pushn '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]")
(get 'schar 'inline-unsafe))
;;SECOND
- (push '((t) t #.(flags)"cadr(#0)")
+ (pushn '((t) t #.(flags)"cadr(#0)")
(get 'second 'inline-safe))
-(push '((t) t #.(flags)"CMPcadr(#0)")
+(pushn '((t) t #.(flags)"CMPcadr(#0)")
(get 'second 'inline-unsafe))
;;SIN
- (push '((long-float) long-float #.(flags rfa)"sin(#0)")
+ (pushn '((long-float) long-float #.(flags rfa)"sin(#0)")
(get 'sin 'inline-always))
;;STRING
- (push '((t) t #.(flags ans)"coerce_to_string(#0)")
+ (pushn '((t) t #.(flags ans)"coerce_to_string(#0)")
(get 'string 'inline-always))
;;STRINGP
- (push '((t) boolean #.(flags rfa)"type_of(#0)==t_string")
+ (pushn '((t) boolean #.(flags rfa)"type_of(#0)==t_string")
(get 'stringp 'inline-always))
;;SVREF
- (push '((t t) t #.(flags ans)"aref1(#0,fixint(#1))")
+ (pushn '((t t) t #.(flags ans)"aref1(#0,fixint(#1))")
(get 'svref 'inline-always))
-(push '((t fixnum) t #.(flags ans)"aref1(#0,#1)")
+(pushn '((t fixnum) t #.(flags ans)"aref1(#0,#1)")
(get 'svref 'inline-always))
-(push '((t t) t #.(flags)"(#0)->v.v_self[fix(#1)]")
+(pushn '((t t) t #.(flags)"(#0)->v.v_self[fix(#1)]")
(get 'svref 'inline-unsafe))
-(push '((t fixnum) t #.(flags)"(#0)->v.v_self[#1]")
+(pushn '((t fixnum) t #.(flags)"(#0)->v.v_self[#1]")
(get 'svref 'inline-unsafe))
;;SYMBOL-NAME
- (push '((t) t #.(flags ans)"symbol_name(#0)")
+ (pushn '((t) t #.(flags ans)"symbol_name(#0)")
(get 'symbol-name 'inline-always))
;;SYMBOL-PLIST
-(push (list '(t) t #.(flags) "((#0)->s.s_plist)")
+(pushn '((t) t #.(flags) "((#0)->s.s_plist)")
(get 'symbol-plist 'inline-unsafe))
;;SYMBOLP
- (push '((t) boolean #.(flags rfa)"type_of(#0)==t_symbol")
+ (pushn '((t) boolean #.(flags rfa)"type_of(#0)==t_symbol")
(get 'symbolp 'inline-always))
;;TAN
- (push '((long-float) long-float #.(flags rfa)"tan(#0)")
+ (pushn '((long-float) long-float #.(flags rfa)"tan(#0)")
(get 'tan 'inline-always))
;;SQRT
- (push '((long-float) long-float #.(flags)"sqrt((double)#0)")
+ (pushn '((long-float) long-float #.(flags)"sqrt((double)#0)")
(get 'sqrt 'inline-always))
- (push '((short-float) short-float #.(flags)"sqrt((double)#0)")
+ (pushn '((short-float) short-float #.(flags)"sqrt((double)#0)")
(get 'sqrt 'inline-always))
- (push '(((long-float 0.0)) (long-float 0.0) #.(flags rfa)"sqrt((double)#0)")
+ (pushn '(((long-float 0.0)) (long-float 0.0) #.(flags rfa)"sqrt((double)#0)")
(get 'sqrt 'inline-always))
- (push '(((short-float 0.0)) (short-float 0.0) #.(flags rfa)"sqrt((double)#0)")
+ (pushn '(((short-float 0.0)) (short-float 0.0) #.(flags
rfa)"sqrt((double)#0)")
(get 'sqrt 'inline-always))
-; (push '(((or (integer 0) (float 0.0))) long-float #.(flags
rfa)"sqrt((double)#0)")
+; (pushn '(((or (integer 0) (float 0.0))) long-float #.(flags
rfa)"sqrt((double)#0)")
; (get 'sqrt 'inline-always))
-; (push '(((integer 0 10)) long-float #.(flags rfa)"sqrt((double)#0)")
+; (pushn '(((integer 0 10)) long-float #.(flags rfa)"sqrt((double)#0)")
; (get 'sqrt 'inline-always))
;;TERPRI
- (push '((t) t #.(flags set)"terpri(#0)")
+ (pushn '((t) t #.(flags set)"terpri(#0)")
(get 'terpri 'inline-always))
-(push '(nil t #.(flags set)"terpri(Cnil)")
+(pushn '(nil t #.(flags set)"terpri(Cnil)")
(get 'terpri 'inline-always))
;;THIRD
- (push '((t) t #.(flags)"caddr(#0)")
+ (pushn '((t) t #.(flags)"caddr(#0)")
(get 'third 'inline-safe))
-(push '((t) t #.(flags)"CMPcaddr(#0)")
+(pushn '((t) t #.(flags)"CMPcaddr(#0)")
(get 'third 'inline-unsafe))
;;TRUNCATE
@@ -1241,86 +1247,86 @@
#+
TRUNCATE_USE_C
;(si::putprop 'truncate 'floor-propagator 'type-propagator)
-(push '((fixnum fixnum) (values fixnum fixnum) #.(flags rfa)"({fixnum
_t=(#0)/(#1);@1(#0)-_t*(#1)@ _t;})")
+(pushn '((fixnum fixnum) (values fixnum fixnum) #.(flags rfa)"({fixnum
_t=(#0)/(#1);@1(#0)-_t*(#1)@ _t;})")
(get 'truncate 'inline-always))
-(push '((fixnum-float) fixnum #.(flags)"(fixnum)(#0)")
+(pushn '((fixnum-float) fixnum #.(flags)"(fixnum)(#0)")
(get 'truncate 'inline-always))
;;FIXME boolean -> t opts
;;VECTORP
- (push '((t) boolean #.(flags rfa)
+ (pushn '((t) boolean #.(flags rfa)
"@0;({enum type _tp=type_of(#0);_tp>=t_string && _tp<=t_vector;})")
(get 'vectorp 'inline-always))
;;SEQUENCEP
- (push '((t) boolean #.(flags rfa)
+ (pushn '((t) boolean #.(flags rfa)
"@0;(listp(#0) || ({enum type _tp=type_of(#0);_tp>=t_string &&
_tp<=t_vector;}))")
(get 'sequencep 'inline-always))
;;FUNCTIONP
- (push '((t) boolean #.(flags rfa)
+ (pushn '((t) boolean #.(flags rfa)
"@0;({enum type _tp=type_of(#0);_tp>=t_ifun && _tp<=t_closure;})")
(get 'functionp 'inline-always))
;;COMPILED-FUNCTION-P
- (push '((t) boolean #.(flags rfa)
+ (pushn '((t) boolean #.(flags rfa)
"@0;({enum type _tp=type_of(#0);_tp>=t_cfun && _tp<=t_closure;})")
(get 'compiled-function-p 'inline-always))
;;WRITE-CHAR
- (push '((t) t #.(flags set)
+ (pushn '((t) t #.(flags set)
"@0;(writec_stream(char_code(#0),Vstandard_output->s.s_dbind),(#0))")
(get 'write-char 'inline-unsafe))
;;ZEROP
- (push '((t) boolean #.(flags rfa)"number_compare(small_fixnum(0),#0)==0")
+ (pushn '((t) boolean #.(flags rfa)"number_compare(small_fixnum(0),#0)==0")
(get 'zerop 'inline-always))
-(push '((fixnum-float) boolean #.(flags rfa)"(#0)==0")
+(pushn '((fixnum-float) boolean #.(flags rfa)"(#0)==0")
(get 'zerop 'inline-always))
;;CMOD
- (push '((t) t #.(flags) "cmod(#0)")
+ (pushn '((t) t #.(flags) "cmod(#0)")
(get 'system:cmod 'inline-always))
;;CTIMES
- (push '((t t) t #.(flags) "ctimes(#0,#1)")
+ (pushn '((t t) t #.(flags) "ctimes(#0,#1)")
(get 'system:ctimes 'inline-always))
;;CPLUS
- (push '((t t) t #.(flags) "cplus(#0,#1)")
+ (pushn '((t t) t #.(flags) "cplus(#0,#1)")
(get 'system:cplus 'inline-always))
;;CDIFFERENCE
- (push '((t t) t #.(flags) "cdifference(#0,#1)")
+ (pushn '((t t) t #.(flags) "cdifference(#0,#1)")
(get 'system:cdifference 'inline-always))
;;IDENTITY
- (push '((t) t #.(flags) "(#0)")
+ (pushn '((t) t #.(flags) "(#0)")
(get 'identity 'inline-always))
;;SI::NEXT-HASH-TABLE-INDEX
- (push '((t t) fixnum #.(flags rfa)
+ (pushn '((t t) fixnum #.(flags rfa)
"({fixnum _i;for (_i=fix(#1);_i<(#0)->ht.ht_size &&
(#0)->ht.ht_self[_i].hte_key==OBJNULL;_i++);_i==(#0)->ht.ht_size ? -1 : _i;})")
(get 'si::next-hash-table-index 'inline-unsafe))
- (push '((t fixnum) fixnum #.(flags rfa)
+ (pushn '((t fixnum) fixnum #.(flags rfa)
"({fixnum _i;for (_i=(#1);_i<(#0)->ht.ht_size &&
(#0)->ht.ht_self[_i].hte_key==OBJNULL;_i++);_i==(#0)->ht.ht_size ? -1 : _i;})")
(get 'si::next-hash-table-index 'inline-unsafe))
;;SI::HASH-ENTRY-BY-INDEX
- (push '((t t) t #.(flags) "(#0)->ht.ht_self[fix(#1)].hte_value")
+ (pushn '((t t) t #.(flags) "(#0)->ht.ht_self[fix(#1)].hte_value")
(get 'si::hash-entry-by-index 'inline-unsafe))
- (push '((t fixnum) t #.(flags) "(#0)->ht.ht_self[(#1)].hte_value")
+ (pushn '((t fixnum) t #.(flags) "(#0)->ht.ht_self[(#1)].hte_value")
(get 'si::hash-entry-by-index 'inline-unsafe))
;;SI::HASH-KEY-BY-INDEX
- (push '((t t) t #.(flags) "(#0)->ht.ht_self[fix(#1)].hte_key")
+ (pushn '((t t) t #.(flags) "(#0)->ht.ht_self[fix(#1)].hte_key")
(get 'si::hash-key-by-index 'inline-unsafe))
- (push '((t fixnum) t #.(flags) "(#0)->ht.ht_self[(#1)].hte_key")
+ (pushn '((t fixnum) t #.(flags) "(#0)->ht.ht_self[(#1)].hte_key")
(get 'si::hash-key-by-index 'inline-unsafe))
;;GETHASH
-(push '((t t *) (values t t) #.(flags)(lambda (key hash &optional default)
+(pushn '((t t *) (values t t) #.(flags)(lambda (key hash &optional default)
(let ((*value-to-go* (or
(pop *values-to-go*)
(and (member
*value-to-go* '(top return) :test (function eq))
@@ -1335,4 +1341,4 @@
;;si::HASH-SET
-(push '((t t t) t #.(flags set) "(sethash(#0,#1,#2),#2)") (get 'si::hash-set
'inline-unsafe))
+(pushn '((t t t) t #.(flags set) "(sethash(#0,#1,#2),#2)") (get 'si::hash-set
'inline-unsafe))
Index: cmpnew/gcl_cmpspecial.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpspecial.lsp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -b -r1.13 -r1.14
--- cmpnew/gcl_cmpspecial.lsp 5 Jun 2006 22:02:45 -0000 1.13
+++ cmpnew/gcl_cmpspecial.lsp 17 Jun 2006 19:26:58 -0000 1.14
@@ -50,7 +50,7 @@
(defun c1declare (args)
(cmperr "The declaration ~s was found in a bad place." (cons 'declare args)))
-(defconstant +useful-c-types+ '(seqind fixnum short-float long-float
proper-list t))
+(defconstant +useful-c-types+ #l(boolean seqind fixnum short-float long-float
proper-list t))
(defun c1the (args &aux info form type dtype)
(when (or (endp args) (endp (cdr args)))
@@ -62,7 +62,7 @@
(setq dtype (type-filter (car args)))
(setq type (type-and dtype (info-type info)))
(when (null type)
- (when (eq (car args) 'boolean) (return-from c1the (c1the (list (car args)
`(unless (eq nil ,(cadr args)) t)))))
+ (when (eq dtype #tboolean) (return-from c1the (c1the (list dtype `(unless
(eq nil ,(cadr args)) t)))))
(when (eq (car form) 'var)
(let* ((v (car (third form)))
(tg (t-to-nil (var-tag v))))
@@ -73,12 +73,12 @@
(nmt (type-and nmt (var-dt v))))
(setf (var-mt v) nmt))
(throw (var-tag v) v)))))
- (setq type (type-filter (car args)))
+ (setq type dtype)
(unless (not (and dtype (info-type info)))
(cmpwarn "Type mismatch was found in ~s.~%Modifying type ~s to ~s."
(cons 'the args) (info-type info) type)))
(setq form (list* (car form) info (cddr form)))
- (if (type>= 'boolean (car args)) (setf (info-type (cadr form)) type)
(set-form-type form type))
+ (if (type>= #tboolean dtype) (setf (info-type (cadr form)) type)
(set-form-type form type))
; (setf (info-type info) type)
form)
Index: cmpnew/gcl_cmptag.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmptag.lsp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -b -r1.12 -r1.13
--- cmpnew/gcl_cmptag.lsp 31 Mar 2006 21:59:38 -0000 1.12
+++ cmpnew/gcl_cmptag.lsp 17 Jun 2006 19:26:58 -0000 1.13
@@ -334,14 +334,14 @@
(defun wt-switch-case (x)
- (cond (x (wt-nl (if (typep x 'fixnum) "case " "") x ":"))))
+ (cond (x (wt-nl (if (typep x #tfixnum) "case " "") x ":"))))
(defun c1switch(form &aux (*tags* *tags*))
(let* ((switch-op (car form))
(body (cdr form))
(switch-op-1 (c1expr switch-op)))
(cond ((and (typep (second switch-op-1 ) 'info)
- (type>= 'fixnum (info-type (second switch-op-1))))
+ (type>= #tfixnum (info-type (second switch-op-1))))
;;optimize into a C switch:
;;If we ever get GCC to do switch's with an enum arg,
;;which don't do bounds checking, then we will
@@ -369,7 +369,7 @@
nil
:ref-ccb nil
:ref-clb nil)))
- (cond((typep x 'fixnum)
+ (cond((typep x #tfixnum)
(setf (tag-ref tag) t)
(setf (tag-switch tag) x))
((eq t x)
@@ -387,7 +387,7 @@
(t (c1expr (cmp-macroexpand-1 (cons 'switch form)))))))
(defun c2switch (op ref-clb ref-ccb body &aux (*inline-blocks* 0)(*vs* *vs*))
- (let ((args (inline-args (list op ) '(fixnum ))))
+ (let ((args (inline-args (list op ) `(,#tfixnum ))))
(wt-inline-loc "switch(#0){" args)
(cond (ref-ccb (c2tagbody-ccb body))
(ref-clb (c2tagbody-clb body))
Index: cmpnew/gcl_cmptop.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmptop.lsp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -b -r1.37 -r1.38
--- cmpnew/gcl_cmptop.lsp 9 Jun 2006 20:50:58 -0000 1.37
+++ cmpnew/gcl_cmptop.lsp 17 Jun 2006 19:26:58 -0000 1.38
@@ -564,8 +564,10 @@
;FIXME should be able to carry a full type here.
(defun sanitize-tp (tp)
- (cond ((and (consp tp) (eq (car tp) 'values) (not (cddr tp))) (cadr
tp))
- ((or (eq tp '*) (and (consp tp) (member (car tp) '(* values)))) '*)
+ (cond ;((and (consp tp) (eq (car tp) 'values) (not (cddr tp))) (cadr
tp))
+ ;((or (eq tp '*) (and (consp tp) (member (car tp) '(* values)))) '*)
+ ((eq tp '*) tp)
+ ((and (consp tp) (eq (car tp) 'values)) (cmp-norm-tp `(values
,@(mapcar 'sanitize-tp (cdr tp)))))
((car (member tp +useful-c-types+ :test 'type<=)))));FIXME recursion
(defvar *recursion-detected*)
@@ -615,21 +617,21 @@
(cmpnote "(proclaim '(ftype (function ~s ~s) ~s~%" al rt fname)
- (let ((oal (get fname 'proclaimed-arg-types))
- (ort (get fname 'proclaimed-return-type)))
+ (let ((oal (get-arg-types fname))
+ (ort (get-return-type fname)))
(when oal
(unless (and (= (length al) (length oal))
(every (lambda (x y) (or (and (eq x '*) (eq y '*))
(type>= y x))) al oal))
(cmpwarn "arg type mismatch in auto-proclamation ~s -> ~s~%" oal
al)
))
(when ort
- (unless (or (and (eq rt '*) (or (eq ort '*) (equal ort '(*))))
(type>= ort rt))
+ (unless (type>= ort rt)
;(cmpwarn "ret type mismatch in auto-proclamation ~s -> ~s~%" ort
rt)
))
(proclaim `(ftype (function ,al ,rt) ,fname));FIXME replace proclaim
- (si::add-hash fname (let* ((at (get fname 'proclaimed-arg-types))
- (rt (get fname 'proclaimed-return-type))
- (rt (if (equal '(*) rt) '* rt)))
+ (si::add-hash fname (let* ((at (get-arg-types fname))
+ (rt (get-return-type fname)))
+; (rt (if (equal '(*) rt) '* rt)))
(when (or at rt) (list at rt))) nil nil)
(when *recursion-detected*;FIXME
(unless (and (equal oal (get fname 'proclaimed-arg-types)) (equal
ort (get fname 'proclaimed-return-type)))
@@ -683,7 +685,7 @@
t))
(type-and (car types) (var-type var))
(or (member (car types)
- '(fixnum character
+ #l(fixnum character
long-float short-float))
(eq (var-loc var) 'object)
*c-gc*
@@ -1463,7 +1465,7 @@
(let ((addr (make-info))
(data (make-info)))
(do-referred (v info)
- (cond ((member (var-type v) '(FIXNUM CHARACTER SHORT-FLOAT
LONG-FLOAT) :test #'eq)
+ (cond ((member (var-type v) #l(FIXNUM CHARACTER SHORT-FLOAT
LONG-FLOAT))
(push-referred v data))
(t
(push-referred v addr))))
@@ -1498,6 +1500,13 @@
+(defconstant +wt-c-var-alist+ `((,#tfixnum ."make_fixnum")
+ (,#tinteger ."make_integer")
+ (,#tcharacter ."code_char")
+ (,#tlong-float ."make_longfloat")
+ (,#tshort-float ."make_shortfloat")
+ (object . "")))
+
(defun wt-global-entry (fname cfun arg-types return-type)
(cond ((get fname 'no-global-entry)(return-from wt-global-entry nil)))
(wt-comment "global entry for the function " (function-string fname))
@@ -1505,25 +1514,22 @@
(wt-nl1 "{ register object *base=vs_base;")
(when (or *safe-compile* *compiler-check-args*)
(wt-nl "check_arg(" (length arg-types) ");"))
- (wt-nl "base[0]=" (case (promoted-c-type return-type)
- (fixnum (if (zerop *space*)
- "CMPmake_fixnum"
- "make_fixnum"))
- (character "code_char")
- (long-float "make_longfloat")
- (short-float "make_shortfloat")
- (otherwise ""))
+ (wt-nl "base[0]=" (let* ((tp (promoted-c-type return-type))
+ (z (cdr (assoc tp +wt-c-var-alist+))))
+ (if (and (eq #tfixnum tp) (zerop *space*))
+ (concatenate 'string "CMP" z) (or z "")));FIXME t
"(" (c-function-name "LI" cfun fname) "(")
(do ((types arg-types (cdr types))
(n 0 (1+ n)))
((endp types))
(declare (object types) (fixnum n))
- (wt (case (promoted-c-type (car types))
- (fixnum "fix")
- (character "char_code")
- (long-float "lf")
- (short-float "sf")
- (otherwise ""))
+ (wt (let ((z (promoted-c-type (car types))))
+ (cond ;FIXME
+ ((eq z #tfixnum) "fix")
+ ((eq z #tcharacter) "char_code")
+ ((eq z #tlong-float) "lf")
+ ((eq z #tshort-float) "sf")
+ ("")))
"(base[" n "])")
(unless (endp (cdr types)) (wt ",")))
(wt "));")
@@ -1531,14 +1537,16 @@
(wt-nl1 "}")
)
+(defconstant +wt-c-rep-alist+ `((,#tfixnum ."fixnum ")
+ (,#tinteger ."GEN ")
+ (,#tcharacter ."unsigned char ")
+ (,#tlong-float ."double ")
+ (,#tshort-float ."float ")
+ (object . "object ")))
+
(defun rep-type (type)
- (case (promoted-c-type type)
- (fixnum "fixnum ")
- (integer "GEN ")
- (character "unsigned char ")
- (short-float "float ")
- (long-float "double ")
- (otherwise "object ")))
+ (let ((z (promoted-c-type type)))
+ (or (cdr (assoc z +wt-c-rep-alist+)) "object ")))
(defun t1defmacro (args)
Index: cmpnew/gcl_cmptype.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmptype.lsp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -b -r1.34 -r1.35
--- cmpnew/gcl_cmptype.lsp 9 Jun 2006 20:50:58 -0000 1.34
+++ cmpnew/gcl_cmptype.lsp 17 Jun 2006 19:26:58 -0000 1.35
@@ -46,6 +46,117 @@
;;; LONG-FLOAT double
+(import 'si::proclaimed-arg-types 'compiler)
+(import 'si::proclaimed-return-type 'compiler)
+(import 'si::proclaimed-function 'compiler)
+(import 'si::proper-list 'compiler)
+(import 'si::subtypep1 'compiler)
+(import 'si::resolve-type 'compiler)
+(import 'si::+inf 'compiler)
+(import 'si::-inf 'compiler)
+(import 'si::nan 'compiler)
+(import 'si::isfinite 'compiler)
+(import 'si::+type-alist+ 'compiler)
+(import 'si::sequencep 'compiler)
+(import 'si::ratiop 'compiler)
+(import 'si::short-float-p 'compiler)
+(import 'si::long-float-p 'compiler)
+(import 'si::interpreted-function 'compiler)
+(import 'si::eql-is-eq 'compiler)
+(import 'si::equal-is-eq 'compiler)
+(import 'si::equalp-is-eq 'compiler)
+(import 'si::eql-is-eq-tp 'compiler)
+(import 'si::equal-is-eq-tp 'compiler)
+(import 'si::equalp-is-eq-tp 'compiler)
+(import 'si::is-eq-test-item-list 'compiler)
+(import 'si::cmp-vec-length 'compiler)
+(import 'si::proclaim-from-argd 'compiler)
+(import 'si::+array-types+ 'compiler)
+(import 'si::+aet-type-object+ 'compiler)
+
+(let ((p (find-package "DEFPACKAGE")))
+ (when p
+ (import (find-symbol "DEFPACKAGE" p) 'compiler)))
+
+
+(defvar *uniq-tp-hash* (make-hash-table :test 'equal))
+(defvar *norm-tp-hash* (make-hash-table :test 'eq))
+
+(defun build-tp (tp)
+ (cond ((atom tp) tp)
+ ((member (car tp) '(and or values cons)) (cons (car tp) (mapcar
'uniq-tp (cdr tp))))
+ ((eq (car tp) 'not) (list (car tp) (uniq-tp (cadr tp))))
+ (tp)))
+
+;(defun uniq-tp (tp)
+; (let ((tp (build-tp tp)))
+; (cond ((gethash tp *uniq-tp-hash*))
+; ((setf (gethash tp *uniq-tp-hash*) tp)))))
+
+(defun uniq-tp (tp)
+ (cond ((gethash tp *uniq-tp-hash*))
+ ((let ((tp (build-tp tp)))
+ (setf (gethash tp *uniq-tp-hash*) tp)))))
+
+;(defun uniq-tp (tp &optional copy)
+; (cond ((atom tp) tp)
+; ((member (car tp) '(and or))
+; ((gethash tp *uniq-tp-hash*))
+; ((let ((tp (if copy (copy-list tp) tp))) (setf (gethash tp
*uniq-tp-hash*) tp)))))
+
+(defun dnt (tp)
+ (uniq-tp
+ (cond ((eq '* tp) '*)
+ ((and (consp tp) (eq (car tp) 'values))
+ (cond ((not (cdr tp)) nil)
+ ((not (cddr tp)) (cmp-norm-tp (cadr tp)))
+ (`(values ,@(mapcar 'cmp-norm-tp (cdr tp))))))
+ ((let ((tp (resolve-type tp))) (if (cadr tp) '* (car tp)))))))
+
+(defun cmp-norm-tp (tp)
+ (multiple-value-bind
+ (r f) (gethash tp *norm-tp-hash*)
+ (cond (f r)
+ ((let ((tp (uniq-tp tp)))
+ (multiple-value-bind
+ (r f) (gethash tp *norm-tp-hash*)
+ (cond (f r)
+ ((let ((nt (dnt tp)))
+ (cond ((and (eq '* nt) (not (eq tp '*))) nt)
+ ((setf (gethash tp *norm-tp-hash*) nt (gethash nt
*norm-tp-hash*) nt))))))))))))
+
+(defun sharp-t-reader (stream subchar arg)
+ (declare (ignore subchar arg))
+ `(load-time-value (cmp-norm-tp ',(read stream))))
+(defun sharp-l-reader (stream subchar arg)
+ (declare (ignore subchar arg))
+ `(load-time-value (mapcar 'cmp-norm-tp ',(read stream))))
+(defun sharp-y-reader (stream subchar arg)
+ (declare (ignore subchar arg))
+ `(load-time-value (mapcar (lambda (x) (cons (cmp-norm-tp (car x)) (cdr x)))
',(read stream))))
+
+(set-dispatch-macro-character #\# #\t 'sharp-t-reader)
+(set-dispatch-macro-character #\# #\l 'sharp-l-reader)
+(set-dispatch-macro-character #\# #\y 'sharp-y-reader)
+
+(defconstant +c-type-string-alist+ #y((t . "object")
+ (bit . "char")
+ (character . "char")
+ (signed-char . "char")
+ (non-negative-char . "char")
+ (unsigned-char . "unsigned char")
+ (signed-short . "short")
+ (non-negative-short . "short")
+ (unsigned-short . "unsigned short")
+ (fixnum . "fixnum")
+ (non-negative-fixnum . "fixnum")
+ (signed-int . "int")
+ (non-negative-int . "int")
+ (unsigned-int . "unsigned int")
+ (long-float . "double")
+ (short-float . "float")))
+
+
;;; Check if THING is an object of the type TYPE.
;;; Depends on the implementation of TYPE-OF.
@@ -60,70 +171,66 @@
(defun object-type (thing &optional lim)
- (let* ((type (type-of thing)))
+ (let* ((type (cmp-norm-tp (type-of thing))))
+ (cmp-norm-tp
(cond ((eq thing t) '(member t))
- ((type>= 'integer type) `(integer ,thing ,thing))
- ((type>= 'short-float type) `(short-float ,thing ,thing))
- ((type>= 'long-float type) `(long-float ,thing ,thing))
- ((eq type 'cons) (cond ((or lim (cons-tp-limit thing 0 0))
+ ((type>= #tinteger type) `(integer ,thing ,thing))
+ ((type>= #tshort-float type) `(short-float ,thing ,thing))
+ ((type>= #tlong-float type) `(long-float ,thing ,thing))
+ ((type>= #tcons type) (cond ((or lim (cons-tp-limit thing 0 0))
`(cons ,(object-type (car thing) t) ,(if (cdr
thing) (object-type (cdr thing) t) 'null)))
((si::improper-consp thing) `(list))
(`(si::proper-list))))
- ((eq type 'keyword) 'symbol)
- ((type>= 'character type) 'character)
- (type))))
-
-(defvar *norm-tp-hash* (make-hash-table :test 'equal))
-(defvar *and-tp-hash* (make-hash-table :test 'equal))
-(defvar *or-tp-hash* (make-hash-table :test 'equal))
+ ((type>= #tkeyword type) 'symbol)
+ ((type>= #tcharacter type) 'character)
+ (type)))))
+(deftype fixnum-float nil `(or fixnum float))
-(defun cmp-norm-tp (tp)
- (multiple-value-bind
- (r f)
- (gethash tp *norm-tp-hash*)
- (cond (f r)
- ((setf (gethash tp *norm-tp-hash*) (let ((tp (resolve-type tp)))
(unless (cadr tp) (car tp))))))))
+
+(defconstant +cmp-type-alist+ (mapcar (lambda (x) (cons (cmp-norm-tp (car x))
(cdr x))) +type-alist+))
+(defconstant +cmp-array-types+ (mapcar 'cmp-norm-tp +array-types+))
+
+;; (defvar *unt* nil)
+
+;; (defun cmpntww (tp)
+;; (let ((nt (cmp-norm-tp tp)))
+;; (unless (eq nt tp)(unless (member tp *unt* :test 'equal) (break "~s~%"
tp))
+;; (pushnew tp *unt* :test 'equal))
+;; nt))
+
+(defmacro cmpntww (tp) tp)
+
+(defmacro uniq-tp-from-stack (op t1 t2)
+ (let ((s (gensym)))
+ `(let ((,s (list ,op ,t1 ,t2)))
+ (declare (:dynamic-extent ,s))
+ (uniq-tp ,s))))
(defun type-and (t1 t2)
- (let ((x (cons t1 t2)))
+ (let* ((t1 (cmpntww t1))
+ (t2 (cmpntww t2))
+ (x (uniq-tp-from-stack `and t1 t2)))
(multiple-value-bind
- (r f)
- (gethash x *and-tp-hash*)
+ (r f) (gethash x *norm-tp-hash*)
(cond (f r)
- ((setf (gethash x *and-tp-hash*) (type-and-int t1 t2)))))))
+ ((setf (gethash x *norm-tp-hash*) (type-and-int t1 t2)))))))
(defun type-or1 (t1 t2)
- (let ((x (cons t1 t2)))
+ (let ((t1 (cmpntww t1))
+ (t2 (cmpntww t2))
+ (x (uniq-tp-from-stack `or t1 t2)))
(multiple-value-bind
(r f)
- (gethash x *or-tp-hash*)
+ (gethash x *norm-tp-hash*)
(cond (f r)
- ((setf (gethash x *or-tp-hash*) (type-or1-int t1 t2)))))))
+ ((setf (gethash x *norm-tp-hash*) (type-or1-int t1 t2)))))))
-(defmacro type-filter (type) `(nil-to-t (cmp-norm-tp ,type)))
+(defmacro type-filter (type) `(cmp-norm-tp ,type))
(defun literalp (form)
(or (constantp form) (and (consp form) (eq (car form) 'load-time-value))))
-;;FIXME -- This function needs expansion on centralization. CM 20050106
-(defun promoted-c-type (type)
- (let ((type (coerce-to-one-value type)))
- (let ((ct (and type (car (member type
-; '(signed-char signed-short fixnum integer)
-; '(signed-char unsigned-char signed-short
unsigned-short fixnum integer)
- '(fixnum integer short-float long-float)
- :test 'type<=)))))
- (cond (ct)
-; ((eq type 'boolean))
- (type)))))
-; (or ct type))))
-; (if (integer-typep type)
-; (cond ;((subtypep type 'signed-char) 'signed-char)
-; ((subtypep type 'fixnum) 'fixnum)
-; ((subtypep type 'integer) 'integer)
-; (t (error "Cannot promote type ~S to C type~%" type)))
-; type)))
;; old propagators
@@ -350,7 +457,7 @@
((< x y)))))
(defun isnan (x)
- (and (floatp x)
+ (and (long-float-p x);FIXME
(not (= +inf x))
(not (= -inf x))
(not (isfinite x))))
@@ -397,12 +504,12 @@
(v (if (and z
(let ((tt (cond (t2p t2) (t1p t1))))
(and
- (type-and tt '(real 0 0))
- (not (type>= '(real 0) tt))
- (not (type>= '(real * 0) tt)))))
+ (type-and tt #t(real 0 0))
+ (not (type>= #t(real 0) tt))
+ (not (type>= #t(real * 0) tt)))))
(cons +inf (cons -inf v)) v)))
(unless (some (lambda (x) (complexp (bound x))) v)
- (mk-tp e (mmin v) (mmax v))))))
+ (cmp-norm-tp (mk-tp e (mmin v) (mmax v)))))))
(dolist (l '(/ floor ceiling truncate round ffloor fceiling ftruncate fround))
(si::putprop l t 'zero-pole))
@@ -416,8 +523,8 @@
(si::putprop 'min 'min-max-propagator 'type-propagator)
(defun /-propagator (f t1 &optional t2)
- (cond (t2 (super-range f t1 (type-and t2 '(not (real 0 0)))))
- ((super-range f (type-and t1 `(not (real 0 0)))))))
+ (cond (t2 (super-range f t1 (type-and t2 #t(not (real 0 0)))))
+ ((super-range f (type-and t1 #t(not (real 0 0)))))))
(si::putprop '/ '/-propagator 'type-propagator)
(defun log-wrap (x y)
@@ -429,7 +536,7 @@
;; (si::putprop 'max 'max-propagator 'type-propagator)
;; (si::putprop 'min 'max-propagator 'type-propagator)
-(defun log-propagator (f t1 &optional (t2 `(short-float ,(exp 1.0s0) ,(exp
1.0s0))))
+(defun log-propagator (f t1 &optional (t2 #t(short-float #.(exp 1.0s0) #.(exp
1.0s0))))
(declare (ignore f))
(super-range 'log-wrap t1 t2))
(si::putprop 'log 'log-propagator 'type-propagator)
@@ -441,26 +548,26 @@
(defun cdr-propagator (f t1)
(declare (ignore f))
- (cond ((type>= 'null t1) t1) ;FIXME clb ccb do-setq-tp
+ (cond ((type>= #tnull t1) t1) ;FIXME clb ccb do-setq-tp
((and (consp t1) (eq (car t1) 'cons)) (caddr t1))
- ((type>= 'proper-list t1) 'proper-list)))
+ ((type>= #tproper-list t1) #tproper-list)))
(si::putprop 'cdr 'cdr-propagator 'type-propagator)
(defun cons-propagator (f t1 t2)
(declare (ignore f))
(cond ((cons-tp-limit t2 0 0) (cmp-norm-tp `(cons ,t1 ,t2)))
- ((type>= 'proper-list t2) (cmp-norm-tp 'proper-list))
- ((cmp-norm-tp 'cons))))
+ ((type>= #tproper-list t2) #tproper-list)
+ (#tcons)))
(si::putprop 'cons 'cons-propagator 'type-propagator)
(defun car-propagator (f t1)
(declare (ignore f))
- (when (type>= 'null t1) 'null))
+ (when (type>= #tnull t1) #tnull))
(si::putprop 'car 'car-propagator 'type-propagator)
(defun mod-propagator (f t1 t2)
(declare (ignore f t1))
- (let ((sr (super-range '* '(integer 0 1) t2)))
+ (let ((sr (copy-tree (super-range '* #t(integer 0 1) t2))))
(when sr
(do ((x (cdr sr) (cdr x))) ((not x) sr)
(unless (or (eq (car x) '*) (consp (car x)) (= (car x) 0))
@@ -473,26 +580,26 @@
(si::putprop 'random 'random-propagator 'type-propagator)
(defun gcd-propagator (f &optional (t1 nil t1p) (t2 nil t2p))
- (cond (t2p (super-range '* '(integer 0 1) (super-range 'min t1 t2)))
+ (cond (t2p (super-range '* #t(integer 0 1) (super-range 'min t1 t2)))
(t1p (mod-propagator f t1 t1))
((super-range f))))
(si::putprop 'gcd 'gcd-propagator 'type-propagator)
(defun lcm-propagator (f &optional (t1 nil t1p) (t2 nil t2p))
- (cond (t2p (super-range '* '(integer 1) (super-range 'max t1 t2)))
+ (cond (t2p (super-range '* #t(integer 1) (super-range 'max t1 t2)))
(t1p (mod-propagator f t1 t1))
((super-range f))))
(si::putprop 'lcm 'lcm-propagator 'type-propagator)
(defun rem-propagator (f t1 t2)
- (let ((t2 (mod-propagator f t1 t2)))
+ (let ((t2 (cmp-norm-tp (mod-propagator f t1 t2))))
(when t2
- (cond ((type>= '(real 0) t1) (type-or1 (type-and '(real 0) t2)
(super-range '- (type-and '(real * 0) t2))))
- ((type>= '(real * 0) t1) (type-or1 (type-and '(real * 0) t2)
(super-range '- (type-and '(real 0) t2))))
+ (cond ((type>= #t(real 0) t1) (type-or1 (type-and #t(real 0) t2)
(super-range '- (type-and #t(real * 0) t2))))
+ ((type>= #t(real * 0) t1) (type-or1 (type-and #t(real * 0) t2)
(super-range '- (type-and #t(real 0) t2))))
((type-or1 t2 (super-range '- t2)))))))
(si::putprop 'rem 'rem-propagator 'type-propagator)
-(defun floor-propagator (f t1 &optional (t2 '(integer 1 1)))
- (let ((sr (super-range f t1 (type-and t2 '(not (real 0 0))))))
+(defun floor-propagator (f t1 &optional (t2 #t(integer 1 1)))
+ (let ((sr (super-range f t1 (type-and t2 #t(not (real 0 0))))))
(when sr
`(values ,sr
,(cond ((member f (sfl floor ffloor)) (mod-propagator f t1
t2))
@@ -504,71 +611,90 @@
(defun ash-propagator (f t1 t2)
(and
- (type>= 'fixnum t1)
- (type>= '(integer #.most-negative-fixnum #.(integer-length
most-positive-fixnum)) t2)
+ (type>= #tfixnum t1)
+ (type>= #t(integer #.most-negative-fixnum #.(integer-length
most-positive-fixnum)) t2)
(super-range f t1 t2)))
(si::putprop 'ash 'ash-propagator 'type-propagator)
(defun expt-propagator (f t1 t2)
- (cond ((or (not (type>= '(real #.(float most-negative-fixnum) #.(float
most-positive-fixnum)) t1))
- (not (type>= '(real #.(float most-negative-fixnum) #.(float
(integer-length most-positive-fixnum))) t2)))
- (let ((v1 (member-if (lambda (x) (type>= t1 x) (type>= x t1))
+real-contagion-list+))
- (v2 (member-if (lambda (x) (type>= t2 x) (type>= x t2))
+real-contagion-list+)))
- (or (car (member (car v1) v2)) (car (member (car v2) v1)))))
- ((type-or1 (super-range f (type-and '(real (0)) t1) t2) (super-range f
(type-and '(real * (0)) t1) t2)))))
+ (cond ((or (not (type>= #t(real #.(float most-negative-fixnum) #.(float
most-positive-fixnum)) t1))
+ (not (type>= #t(real #.(float most-negative-fixnum) #.(float
(integer-length most-positive-fixnum))) t2)))
+ (let ((rcl (load-time-value (mapcar 'cmp-norm-tp
+real-contagion-list+))))
+ (let ((v1 (member-if (lambda (x) (type>= t1 x) (type>= x t1)) rcl))
+ (v2 (member-if (lambda (x) (type>= t2 x) (type>= x t2)) rcl)))
+ (or (car (member (car v1) v2)) (car (member (car v2) v1))))))
+ ((type-or1 (super-range f (type-and #t(real (0)) t1) t2) (super-range f
(type-and #t(real * (0)) t1) t2)))))
(si::putprop 'expt 'expt-propagator 'type-propagator)
(defun integer-length-propagator (f t1)
- (when (type>= 'fixnum t1) (type-or1 (super-range f (type-and '(real 0) t1))
(super-range f (type-and '(real * 0) t1)))))
+ (when (type>= #tfixnum t1) (type-or1 (super-range f (type-and #t(real 0)
t1)) (super-range f (type-and #t(real * 0) t1)))))
(si::putprop 'integer-length 'integer-length-propagator 'type-propagator)
(defun abs-propagator (f t1)
(declare (ignore f))
- (type-and (type-or1 t1 (super-range '- t1)) '(real 0)))
+ (type-and (type-or1 t1 (super-range '- t1)) #t(real 0)))
(si::putprop 'abs 'abs-propagator 'type-propagator)
+(defmacro vt (tp) `(and (consp ,tp) (eq (car ,tp) 'values)))
;;FIXME -- centralize subtypep, normalzie-type, type>=, type-and.
;;Consider traversing a static tree. CM 20050106
(defun type-and-int (type1 type2)
-
- (cond ((member type1 '(t object *)) type2)
- ((member type2 '(t object *)) type1)
+ (cond ((eq type1 '*) type2)
+ ((eq type2 '*) type1)
((equal type1 type2) type2)
- ((and (consp type2) (eq (car type2) 'values))
- (if (and (consp type1) (eq (car type1) 'values))
- (let ((r (list 'values)))
- (do ((t1 (cdr type1) (cdr t1))
- (t2 (cdr type2) (cdr t2)))
- ((not (and (consp t1) (consp t2))) (nreverse r))
- (push (type-and (car t1) (car t2)) r)))
- (type-and type1 (second type2))))
- ((and (consp type1) (eq (car type1) 'values))
- (type-and (second type1) type2))
+ ((or (vt type1) (vt type2))
+ (let* ((ntype1 (if (vt type1) type1 `(values ,@(when type1 (list
type1)))))
+ (ntype2 (if (vt type2) type2 `(values ,@(when type2 (list
type2)))))
+ (l1 (length ntype1))
+ (l2 (length ntype2)))
+ (cond ((and (every 'type>= (cdr ntype1) (cdr ntype2)) (>= l1 l2))
type2)
+ ((and (every 'type>= (cdr ntype2) (cdr ntype1)) (>= l2 l1))
type1)
+ ((cmp-norm-tp `(values ,@(mapcar 'type-and (cdr ntype1) (cdr
ntype2))))))))
+ ((member type1 '(t object)) type2)
+ ((member type2 '(t object)) type1)
((subtypep1 type2 type1) type2)
((subtypep1 type1 type2) type1)
((cmp-norm-tp `(and ,type1 ,type2)))))
(defun type>= (type1 type2)
- (equal (type-and type1 type2) type2))
+ (let ((t1 (cmpntww type1))
+ (t2 (cmpntww type2)))
+ (let ((z (type-and t1 t2)))
+ (when (and (equal z t2) (not (eq z t2))) (cmpwarn "eq type2 prob: ~s
~s~%" t1 t2))
+ ; (when (not (eq type1 (cmp-norm-tp
type1))) (cmpwarn "unnorm type1 ~s~%" type1))
+ ; (when (not (eq type2 (cmp-norm-tp
type2))) (cmpwarn "unnorm type2 ~s~%" type2))
+ (equal z t2))))
(defun type<= (type1 type2)
- (equal (type-and type2 type1) type1))
+ (let ((t1 (cmpntww type1))
+ (t2 (cmpntww type2)))
+ (let ((z (type-and t2 t1)))
+ (when (and (equal z t1) (not (eq z t1))) (cmpwarn "eq type1 prob: ~s
~s~%" t1 t2))
+ ; (when (not (eq type1 (cmp-norm-tp
type1))) (cmpwarn "unnorm type1 ~s~%" type1))
+ ; (when (not (eq type2 (cmp-norm-tp
type2))) (cmpwarn "unnorm type2 ~s~%" type2))
+ (equal z t1))))
+; (equal (type-and type2 type1) type1))
(defun type-or1-int (type1 type2)
- (cond ((equal type1 type2) type2)
- ((and (consp type1) (eq (car type1) 'values))
- (let ((r (list 'values)))
- (do ((t1 (cdr type1) (cdr t1))
- (t2 (if (and (consp type2) (eq (car type2) 'values)) (cdr
type2) (list type2)) (cdr t2)))
- ((not (or (consp t1) (consp t2))) (nreverse r))
- (push (type-or1 (or (car t1) 'null) (or (car t2) 'null)) r))))
- ((and (consp type2) (eq (car type2) 'values))
- (type-or1 type2 type1))
- ;;FIXME!!! This belongs in predlib.
- ((and (= 2 (length (intersection (list type1 type2) '(proper-list (cons
t proper-list)) :test 'equal))) 'proper-list))
- ((member type1 '(t object *)) type1)
- ((member type2 '(t object *)) type2)
+ (cond ((eq type1 '*) type1)
+ ((eq type2 '*) type2)
+ ((or (and (consp type1) (eq (car type1) 'values))
+ (and (consp type2) (eq (car type2) 'values)))
+ (let* ((ntype1 (if (vt type1) type1 `(values ,@(when type1 (list
type1)))))
+ (ntype2 (if (vt type2) type2 `(values ,@(when type2 (list
type2)))))
+ (l1 (length ntype1))
+ (l2 (length ntype2))
+ (n (- (max l1 l2) (min l1 l2)))
+ (e (make-list n :initial-element #tnull))
+ (ntype1 (if (< l1 l2) (append ntype1 e) ntype1))
+ (ntype2 (if (< l2 l1) (append ntype2 e) ntype2)))
+ (cond ((and (every 'type>= (cdr ntype2) (cdr ntype1)) (>= l2 l1))
type2)
+ ((and (every 'type>= (cdr ntype1) (cdr ntype2)) (>= l1 l2))
type1)
+ ((cmp-norm-tp `(values ,@(mapcar 'type-or1 (cdr ntype1) (cdr
ntype2))))))))
+ ((equal type1 type2) type2)
+ ((member type1 '(t object)) type1)
+ ((member type2 '(t object)) type2)
((subtypep1 type1 type2) type2)
((subtypep1 type2 type1) type1)
((type-filter `(or ,type1 ,type2)))))
@@ -583,7 +709,7 @@
;(defun reset-info-type (x) x)
(defun and-form-type (type form original-form &aux type1)
- (setq type1 (type-and type (info-type (cadr form))))
+ (setq type1 (type-and type (coerce-to-one-value (info-type (cadr form)))))
(when (and (null type1) type (info-type (cadr form)))
(cmpwarn "The type of the form ~s is not ~s, but ~s." original-form
type (info-type (cadr form))))
(if (eq type1 (info-type (cadr form)))
@@ -593,17 +719,7 @@
(list* (car form) info (cddr form)))))
(defun check-form-type (type form original-form)
- (when (and (null (type-and type (info-type (cadr form)))) type (info-type
(cadr form)))
+ (when (and (null (type-and type (coerce-to-one-value (info-type (cadr
form))))) type (info-type (cadr form)))
(cmpwarn "The type of the form ~s is not ~s, but ~s." original-form
type (info-type (cadr form)))))
-(defconstant +c1nil+ (list 'LOCATION (make-info :type (object-type nil)) nil))
-(defmacro c1nil () `+c1nil+)
-(defconstant +c1t+ (list 'LOCATION (make-info :type (object-type t)) t))
-(defmacro c1t () `+c1t+)
-
-(defun default-init (type)
- (let ((type (promoted-c-type type)))
- (when (member type +c-local-var-types+)
- (cmpwarn "The default value of NIL is not ~S." type)))
- (c1nil))
Index: cmpnew/gcl_cmpvar.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpvar.lsp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -b -r1.17 -r1.18
--- cmpnew/gcl_cmpvar.lsp 5 Jun 2006 22:02:45 -0000 1.17
+++ cmpnew/gcl_cmpvar.lsp 17 Jun 2006 19:26:58 -0000 1.18
@@ -228,6 +228,14 @@
(or (si::fixnump n) (wfs-error))
(wt "base0[" n "]"))
+(defconstant +wt-c-var-alist+ `((,#tfixnum ."make_fixnum")
+ (,#tinteger ."make_integer")
+ (,#tcharacter ."code_char")
+ (,#tlong-float ."make_longfloat")
+ (,#tshort-float ."make_shortfloat")
+ (object . "")))
+
+
(defun wt-var (var ccb)
(case (var-kind var)
(LEXICAL (cond (ccb (wt-ccb-vs (var-ref-ccb var)))
@@ -245,16 +253,12 @@
(GLOBAL (if *safe-compile*
(wt "symbol_value(VV[" (var-loc var) "])")
(wt "(VV[" (var-loc var) "]->s.s_dbind)")))
- (t (case (var-kind var)
- (FIXNUM (when (zerop *space*) (wt "CMP"))
- (wt "make_fixnum"))
- (INTEGER (wt "make_integer"))
- (CHARACTER (wt "code_char"))
- (LONG-FLOAT (wt "make_longfloat"))
- (SHORT-FLOAT (wt "make_shortfloat"))
- (OBJECT)
- (t (baboon)))
- (wt "(V" (var-loc var) ")"))
+ (t (let ((z (cdr (assoc (var-kind var) +wt-c-var-alist+))))
+ (unless z (baboon))
+ (when (and (eq #tfixnum (var-kind var)) (zerop *space*))
+ (wt "CMP"))
+ (wt z)
+ (wt "(V" (var-loc var) ")")))
))
;; When setting bignums across setjmps, cannot use alloca as longjmp
@@ -284,7 +288,8 @@
(DOWN
(wt-nl "") (wt-down (var-loc var))
(wt "=" loc ";"))
- (INTEGER
+ (t
+ (cond ((eq (var-kind var) #tinteger)
(let ((first (and (consp loc) (car loc)))
(n (var-loc var)))
(case first
@@ -292,14 +297,13 @@
(wt-nl "ISETQ_FIX(V"n",V"n"alloc,")
(wt-inline-loc (caddr loc) (cadddr loc)))
(fixnum-value (wt-nl "ISETQ_FIX(V"n",V"n"alloc,"(caddr loc)))
-
(var
- (case (var-kind (cadr loc))
- (integer (wt "SETQ_II(V"n",V"n"alloc,V" (var-loc (cadr
loc)) ","
- (bignum-expansion-storage)))
- (fixnum (wt "ISETQ_FIX(V"n",V"n"alloc,V" (var-loc (cadr
loc))))
- (otherwise (wt "SETQ_IO(V"n",V"n"alloc,"loc ","
- (bignum-expansion-storage)))))
+ (cond
+ ((eq (var-kind (cadr loc)) #tinteger)
+ (wt "SETQ_II(V"n",V"n"alloc,V" (var-loc (cadr loc))
"," (bignum-expansion-storage)))
+ ((eq (var-kind (cadr loc)) #tfixnum)
+ (wt "ISETQ_FIX(V"n",V"n"alloc,V" (var-loc (cadr
loc))))
+ ((wt "SETQ_IO(V"n",V"n"alloc,"loc ","
(bignum-expansion-storage)))))
(vs (wt "SETQ_IO(V"n",V"n"alloc,"loc ","
(bignum-expansion-storage)))
(otherwise
@@ -309,13 +313,12 @@
(wt-integer-loc loc)
(wt "," (bignum-expansion-storage) ");")
(close-inline-blocks))
- (return-from set-var nil))
- )
+ (return-from set-var nil)))
(wt ");")))
(t
(wt-nl "V" (var-loc var) "= ")
(funcall (or (cdr (assoc (var-kind var) +wt-loc-alist+)) (baboon))
loc)
- (wt ";")))))
+ (wt ";")))))))
(defun sch-global (name)
(dolist* (var *undefined-vars* nil)
@@ -366,7 +369,7 @@
(throw (var-tag v) v))))))
(defun set-form-type (form type)
- (let* ((it (info-type (cadr form)))
+ (let* ((it (coerce-to-one-value (info-type (cadr form))))
(nt (type-and type it)))
(unless (or nt (not (and type it)))
(cmpwarn "Type mismatch: ~s ~s~%" it type))
@@ -375,8 +378,8 @@
((let let*) (set-form-type (car (last form)) type))
(progn (set-form-type (car (last (third form))) type))
(if
- (let ((tt (type-and type (info-type (cadr (fourth form)))))
- (ft (type-and type (info-type (cadr (fifth form))))))
+ (let ((tt (type-and type (coerce-to-one-value (info-type (cadr
(fourth form))))))
+ (ft (type-and type (coerce-to-one-value (info-type (cadr
(fifth form)))))))
(unless tt
(set-form-type (fifth form) type)
(setf (car form) 'progn (cadr form) (cadr (fifth form)) (caddr
form) (list (fifth form)) (cdddr form) nil))
@@ -505,9 +508,9 @@
(defun wt-var-decl (var)
(cond ((var-p var)
(let ((n (var-loc var)))
- (cond ((eq (var-kind var) 'integer)(wt "IDECL(")))
+ (cond ((eq (var-kind var) #tinteger)(wt "IDECL(")))
(wt *volatile* (register var) (rep-type (var-kind var))
"V" n )
- (if (eql (var-kind var) 'integer) (wt ",V"n"space,V"n"alloc)"))
+ (if (eql (var-kind var) #tinteger) (wt ",V"n"space,V"n"alloc)"))
(wt ";")))
(t (wfs-error))))
Index: cmpnew/gcl_collectfn.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_collectfn.lsp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -b -r1.7 -r1.8
--- cmpnew/gcl_collectfn.lsp 31 Mar 2006 21:59:38 -0000 1.7
+++ cmpnew/gcl_collectfn.lsp 17 Jun 2006 19:26:58 -0000 1.8
@@ -169,7 +169,7 @@
(defun result-type-from-loc (x)
(cond ((consp x)
(case (car x)
- ((fixnum-value inline-fixnum) 'fixnum)
+ ((fixnum-value inline-fixnum) #tfixnum)
(var (var-type (second x)))
;; eventually separate out other inlines
(t (cond ((and (symbolp (car x))
@@ -274,7 +274,7 @@
(add-value-type nil (or fname 'unknown-values))
(add-value-type (result-type-from-loc loc) nil)))
(return-fixnum
- (add-value-type 'fixnum nil))
+ (add-value-type #tfixnum nil))
(return-object
(add-value-type t nil))
(top (setq *top-data* (cons fname nil)))))
Index: cmpnew/gcl_lfun_list.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_lfun_list.lsp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -b -r1.12 -r1.13
--- cmpnew/gcl_lfun_list.lsp 8 Jun 2006 18:40:08 -0000 1.12
+++ cmpnew/gcl_lfun_list.lsp 17 Jun 2006 19:26:58 -0000 1.13
@@ -36,7 +36,7 @@
(DEFSYSFUN 'FILE-AUTHOR "Lfile_author" '(T) 'T NIL NIL)
(DEFSYSFUN 'STRING-CAPITALIZE "Lstring_capitalize" '(T *) 'STRING NIL
NIL)
-(DEFSYSFUN 'MACROEXPAND "Lmacroexpand" '(T *) '(VALUES T T) NIL NIL)
+(DEFSYSFUN 'MACROEXPAND "Lmacroexpand" '(T *) '(VALUES PROPER-LIST BOOLEAN)
NIL NIL)
(DEFSYSFUN 'NCONC "Lnconc" '(*) 'T NIL NIL)
(DEFSYSFUN 'BOOLE "Lboole" '(T T T) 'T NIL NIL)
(DEFSYSFUN 'TAILP "Ltailp" '(T T) 'T NIL T)
Index: cmpnew/sys-proclaim.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/sys-proclaim.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -b -r1.23 -r1.24
--- cmpnew/sys-proclaim.lisp 22 Mar 2006 15:51:16 -0000 1.23
+++ cmpnew/sys-proclaim.lisp 17 Jun 2006 19:26:58 -0000 1.24
@@ -19,10 +19,10 @@
(PROCLAIM
'(FTYPE (FUNCTION (T (ARRAY T (*)) FIXNUM T) FIXNUM) PUSH-ARRAY))
(PROCLAIM
- '(FTYPE (FUNCTION (T T T) *) IS-EQ-TEST-ITEM-LIST C2COMPILER-LET
+ '(FTYPE (FUNCTION (T T T) *) C2COMPILER-LET
C2IF C2LABELS C2FLET WT-INLINE))
(PROCLAIM
- '(FTYPE (FUNCTION (T T *) T) DO-VECTOR-MAP DO-SEQUENCE-SEARCH
+ '(FTYPE (FUNCTION (T T *) T) RANDOM-PROPAGATOR LIST-TP-TEST DO-VECTOR-MAP
DO-SEQUENCE-SEARCH
DO-LIST-SEARCH C2LAMBDA-EXPR INLINE-ARGS
AREF-PROPAGATOR C2FUNCALL ARRAY-ROW-MAJOR-INDEX-EXPANDER
FLOOR-PROPAGATOR))
@@ -52,7 +52,7 @@
'(FTYPE (FUNCTION (T T T *) T) POSSIBLE-EQ-LIST-SEARCH NUM-TYPE-REL
WT-SIMPLE-CALL))
(PROCLAIM
- '(FTYPE (FUNCTION (T T T T) T) T3DEFUN-NORMAL T3DEFUN-VARARG
+ '(FTYPE (FUNCTION (T T T T) T) IS-EQ-TEST-ITEM-LIST T3DEFUN-NORMAL
T3DEFUN-VARARG
C1MAKE-VAR C2SWITCH INLINE-TYPE-MATCHES C2STRUCTURE-REF
C2CALL-UNKNOWN-GLOBAL C2CALL-GLOBAL MY-CALL PUT-PROCLS
WT-GLOBAL-ENTRY))
@@ -82,7 +82,7 @@
WT-TO-STRING))
(PROCLAIM
'(FTYPE (FUNCTION (*) T) CS-PUSH FCALLN-INLINE MAKE-VAR
- RANDOM-PROPAGATOR MAKE-TAG LIST*-INLINE MAKE-INFO
+ MAKE-TAG LIST*-INLINE MAKE-INFO
LIST-INLINE CMP-ARRAY-DIMENSION-INLINE-TYPES
CMP-ASET-INLINE-TYPES CMP-AREF-INLINE-TYPES
CMP-ARRAY-ELEMENT-TYPE MAKE-FUN MAKE-BLK WT-CLINK
@@ -154,7 +154,7 @@
BLK-REF-CCB BLK-REF-CLB BLK-REF BLK-NAME))
(PROCLAIM
'(FTYPE (FUNCTION (T T) *) C2DECL-BODY C2RETURN-LOCAL C2BLOCK-LOCAL
- C2BLOCK LIST-TP-TEST C1SYMBOL-FUN C1BODY WT-INLINE-LOC))
+ C2BLOCK C1SYMBOL-FUN C1BODY WT-INLINE-LOC))
(PROCLAIM
'(FTYPE (FUNCTION (T *) T) OBJECT-TYPE SUPER-RANGE CMPNOTE CMPWARN CMPERR
INTEGER-NORM-FORM
INIT-NAME UNWIND-EXIT C1LAMBDA-EXPR C1CASE
Index: lsp/gcl_callhash.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_callhash.lsp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -b -r1.3 -r1.4
--- lsp/gcl_callhash.lsp 8 Jun 2006 18:54:08 -0000 1.3
+++ lsp/gcl_callhash.lsp 17 Jun 2006 19:26:58 -0000 1.4
@@ -169,6 +169,26 @@
+(defun recompile (fn &optional (pn "/tmp/recompile.lsp" pnp))
+ (unless pnp (when (probe-file pn) (delete-file pn)))
+ (with-open-file
+ (s pn :direction :output :if-exists :append :if-does-not-exist :create)
+ (let ((*print-radix* nil)
+ (*print-base* 10)
+ (*print-circle* t)
+ (*print-pretty* nil)
+ (*print-level* nil)
+ (*print-length* nil)
+ (*print-case* :downcase)
+ (*print-gensym* t)
+ (*print-array* t)
+ (si::*print-package* t)
+ (si::*print-structure* t))
+ (let* ((src (function-src fn)))
+ (if src (prin1 `(defun ,fn ,@(cdr src)) s)
+ (remove-recompile fn))
+ (load (compile-file pn :system-p t :c-file t :h-file t :data-file
t))))))
+
(defun do-recompile (&optional (pn "/tmp/recompile.lsp" pnp))
(unless (or *disable-recompile* (= 0 (length *needs-recompile*)))
(let ((*disable-recompile* t))
@@ -205,8 +225,8 @@
(do-recompile pn)))
;FIXME!!!
-(defun is-eq-test-item-list (&rest r)
- (format t "Should never be called ~s~%" r))
+(defun is-eq-test-item-list (x y z w)
+ (format t "Should never be called ~s ~s ~s ~s~%" x y z w))
(defun cmp-vec-length (x)
(declare (vector x))
Index: lsp/gcl_predlib.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_predlib.lsp,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -b -r1.45 -r1.46
--- lsp/gcl_predlib.lsp 16 May 2006 16:44:59 -0000 1.45
+++ lsp/gcl_predlib.lsp 17 Jun 2006 19:26:58 -0000 1.46
@@ -131,10 +131,10 @@
((file-stream string-stream synonym-stream concatenated-stream
broadcast-stream two-way-stream echo-stream) (eq (type-of-c
object) tp))
(t (cond
- ((setq tem (when (symbolp tp) (get tp 'deftype-definition)))
- (typep-int object (dt-apply tem i)))
((if (symbolp tp) (get tp 's-data) (typep-int tp 's-data))
(let ((z (structure-subtype-p object tp))) z))
+ ((setq tem (when (symbolp tp) (get tp 'deftype-definition)))
+ (typep-int object (dt-apply tem i)))
((classp tp)
(subtypep1 (class-of object) tp))))))
@@ -298,6 +298,10 @@
(coerce (imagpart object) (cadr type)))))
(otherwise (check-type-eval object type)))))
+(defun maybe-clear-tp (sym)
+ (let* ((p (find-package "COMPILER")) (s (and p (find-symbol "*NORM-TP-HASH*"
p))))
+ (when (and s (boundp s)) (remhash sym (symbol-value s)))))
+
;;; DEFTYPE macro.
(defmacro deftype (name lambda-list &rest body &aux decls prot)
;; Replace undefaultized optional parameter X by (X '*).
@@ -331,6 +335,7 @@
(proclaim '(ftype (function ,prot t) ,fun-name))
(defun ,fun-name ,lambda-list ,@decls (block ,name ,@body))
(putprop ',name ',fun-name 'deftype-definition)
+ (maybe-clear-tp ',name)
(putprop ',name
,(find-documentation body)
'type-documentation)
@@ -478,6 +483,7 @@
(deftype function (&optional as vs)
(declare (ignore as vs))
`(or interpreted-function compiled-function generic-function))
+(deftype generic-function nil nil);Overwritten by pcl check
(deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high))
(deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high))
@@ -547,8 +553,13 @@
(defun long-float-p (x)
(and (floatp x) (eql x (float x 0.0))))
-(defun proper-listp (x)
- (or (not x) (and (consp x) (not (improper-consp x)))))
+;(defun proper-listp (x)
+; (or (not x) (and (consp x) (not (improper-consp x)))))
+
+(deftype proper-list () `(or null proper-cons))
+
+(defun proper-consp (x)
+ (and (consp x) (not (improper-consp x))))
(deftype not-type nil 'null)
@@ -561,7 +572,7 @@
(keyword . keywordp)
(non-logical-pathname . non-logical-pathname-p)
(logical-pathname . logical-pathname-p)
- (proper-list . proper-listp)
+ (proper-cons . proper-consp)
(non-keyword-symbol . non-keyword-symbol-p)
(standard-char . standard-char-p)
(non-standard-base-char . non-standard-base-char-p)
@@ -605,7 +616,7 @@
(defconstant +singleton-types+ '(non-keyword-symbol keyword standard-char
non-standard-base-char
- package cons-member proper-list
+ package cons-member proper-cons
broadcast-stream concatenated-stream
echo-stream file-stream string-stream
synonym-stream two-way-stream
non-logical-pathname logical-pathname
@@ -727,24 +738,31 @@
((member (car type) '(member eql)) type)
((copy-type (cdr type) (cons (car type) res)))))
+(defun expand-proper-cons (tp lt)
+ (cond ((atom tp))
+ ((equal (car tp) '(proper-cons)) (setf (car tp) `(or (cons (t) (member
nil)) (cons (t) (proper-cons)) ,@lt)))
+ ((eq (car tp) 'cons))
+ ((and (expand-proper-cons (car tp) lt) (expand-proper-cons (cdr tp)
lt)))))
+
(defun normalize-type (tp &optional ar);FIXME
(let* ((tp (normalize-type-int tp ar))
(lt (list-types tp)))
- (if lt
- (nsublis `(((proper-list) . (or (member nil) (cons (t) (proper-list))
,@lt))) tp :test 'equal)
- tp)))
+ (when lt (expand-proper-cons tp lt))
+ tp))
(defmacro maybe-eval (x) `(if (and (consp ,x) (eq (car ,x) 'load-time-value))
(eval (cadr ,x)) ,x))
-(defun proper-cons-tp (tp)
- (cond ((eq (car tp) 'cons) (cons 'cons (list '(t) (proper-cons-tp (caddr
tp)))))
- ('(member nil))))
+(defun proper-cons-tp (tp end)
+ (cond ((eq (car tp) 'cons) (cons 'cons (list '(t) (proper-cons-tp (caddr tp)
end))))
+ (end)))
(defun list-types (tp &optional r)
(cond ((atom tp) r)
((consp (car tp)) (let ((r (list-types (car tp) r))) (list-types (cdr
tp) r)))
- ((and (eq (car tp) 'member) (member nil tp)) (pushnew '(member nil) r
:test 'eq) (list-types (cdr tp) r))
- ((eq (car tp) 'cons) (pushnew (proper-cons-tp tp) r :test 'equal)
(list-types (cdr tp) r))
+ ((eq (car tp) 'cons)
+ (pushnew (proper-cons-tp tp '(proper-cons)) r :test 'equal)
+ (pushnew (proper-cons-tp tp '(member nil)) r :test 'equal)
+ (list-types (cdr tp) r))
((list-types (cdr tp) r))))
@@ -1038,7 +1056,7 @@
;; SINGLETON-TYPES
(defun single-load (ntp type)
- (ntp-ld ntp `(,(car type) t)))
+ (ntp-ld ntp `(,(car type) ,(or (cadr type) t))))
(defun single-atm (x)
(cond ((or (eq x t) (not x)))
@@ -1071,7 +1089,8 @@
(not (negate (cadr x))))))
(defun single-recon (x)
- (cond ((atom (cadr x)) (car x))
+ (cond ((eq (cadr x) t) (car x))
+ ((and (consp (cadr x)) (eq (caadr x) 'not)) `(and ,(car x) ,(cadr x)))
((cadr x))))
@@ -1122,11 +1141,13 @@
(not (negate (cadr x))))))
(defun array-recon (x)
- `(array ,(car (rassoc (car x) +array-type-alist+)) ,(cond ((eq (cadr x) t)
'*) ((atom (cadr x)) (cadr x)) ((mapcar (lambda (x) (if (eq x t) '* x)) (cadr
x))))))
+ `(array ,(car (rassoc (car x) +array-type-alist+))
+ ,(cond ((eq (cadr x) t) '*) ((atom (cadr x)) (cadr x))
+ ((mapcar (lambda (x) (if (eq x t) '* x)) (cadr x))))))
;; STRUCTURES
-(defun structure-load (ntp type) (single-load ntp type));;FIXME macro
+(defun structure-load (ntp type) (single-load ntp type))
(defun structure-atm (x) (standard-atm x))
@@ -1147,7 +1168,7 @@
((and or) (sigalg-op op (cadr x) (cadr y) 'structure^
'structure-atm))
(not (negate (cadr x))))))
-(defun structure-recon (x) (cadr x))
+(defun structure-recon (x) (single-recon x))
;; STANDARD-OBJECTS
@@ -1180,7 +1201,7 @@
((and or) (sigalg-op op (cadr x) (cadr y) 'standard^
'standard-atm))
(not (negate (cadr x))))))
-(defun standard-recon (x) (cadr x))
+(defun standard-recon (x) (let ((z (cadr x))) (if (eq z t) (or (find-class
'standard-object) 'standard-object) z)))
;; CONS
Index: pcl/gcl_pcl_impl_low.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/pcl/gcl_pcl_impl_low.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- pcl/gcl_pcl_impl_low.lisp 14 Mar 2006 23:46:41 -0000 1.5
+++ pcl/gcl_pcl_impl_low.lisp 17 Jun 2006 19:26:58 -0000 1.6
@@ -149,8 +149,14 @@
(defentry %fboundp (object) (object __fboundp))
-(eval-when (compile eval load)
+(eval-when (compile eval load);FIXME do pushn here from compiler
+(defun do-norm (entry)
+ `(,(car entry) ,(mapcar 'compiler::cmp-norm-tp (cadr entry))
+ ,(compiler::cmp-norm-tp (caddr entry))
+ ,@(cdddr entry)))
+
(defparameter *gcl-function-inlines*
+ (mapcar 'do-norm
'( (%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL")
(%symbol-function (t) t nil nil "(#0)->s.s_gfdef")
(si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")
@@ -162,8 +168,7 @@
(%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")
#+turbo-closure
(%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")
-
- (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))
+ (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))))
(defun make-function-inline (inline)
(setf (get (car inline) 'compiler::inline-always)
@@ -190,7 +195,7 @@
(cadr inline))))
`((eval-when (compile eval load)
(make-function-inline
- ',(cons name (cdr inline))))
+ `(,',name ,@(cdr (assoc ',(car inline)
*gcl-function-inlines*)))))
,@(when (or (every #'(lambda (type) (eq type 't))
(cadr inline))
(char= #\% (aref (symbol-name (car inline))
0)))
@@ -200,7 +205,7 @@
`((declare (type ,var-type
,var)))))
vars (cadr inline))
(the ,(caddr inline) (,name ,@vars)))
- (make-function-inline ',inline))))))
+ (make-function-inline `(,',(car inline) ,@(cdr
(assoc ',(car inline) *gcl-function-inlines*)))))))))
*gcl-function-inlines*)))
(define-inlines)
Index: unixport/sys_ansi_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_ansi_gcl.c,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -b -r1.16 -r1.17
--- unixport/sys_ansi_gcl.c 5 Jun 2006 22:02:46 -0000 1.16
+++ unixport/sys_ansi_gcl.c 17 Jun 2006 19:26:58 -0000 1.17
@@ -105,13 +105,14 @@
ar_check_init(gcl_ansi_io,no_init);
+ ar_check_init(gcl_cmptype,no_init);
ar_check_init(gcl_cmpinline,no_init);
ar_check_init(gcl_cmputil,no_init);
ar_check_init(gcl_debug,no_init);
ar_check_init(gcl_info,no_init);
- ar_check_init(gcl_cmptype,no_init);
+/* ar_check_init(gcl_cmptype,no_init); */
ar_check_init(gcl_cmpbind,no_init);
ar_check_init(gcl_cmpblock,no_init);
ar_check_init(gcl_cmpcall,no_init);
Index: unixport/sys_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_gcl.c,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -b -r1.24 -r1.25
--- unixport/sys_gcl.c 5 Jun 2006 22:02:46 -0000 1.24
+++ unixport/sys_gcl.c 17 Jun 2006 19:26:58 -0000 1.25
@@ -106,13 +106,14 @@
ar_check_init(gcl_sloop,no_init);
ar_check_init(gcl_serror,no_init);
+ ar_check_init(gcl_cmptype,no_init);
ar_check_init(gcl_cmpinline,no_init);
ar_check_init(gcl_cmputil,no_init);
ar_check_init(gcl_debug,no_init);
ar_check_init(gcl_info,no_init);
- ar_check_init(gcl_cmptype,no_init);
+/* ar_check_init(gcl_cmptype,no_init); */
ar_check_init(gcl_cmpbind,no_init);
ar_check_init(gcl_cmpblock,no_init);
ar_check_init(gcl_cmpcall,no_init);
Index: unixport/sys_mod_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_mod_gcl.c,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -b -r1.11 -r1.12
--- unixport/sys_mod_gcl.c 5 Jun 2006 22:02:46 -0000 1.11
+++ unixport/sys_mod_gcl.c 17 Jun 2006 19:26:58 -0000 1.12
@@ -108,13 +108,14 @@
/* ar_check_init(gcl_ansi_io,no_init); deleted by kraehe */
+ ar_check_init(gcl_cmptype,no_init);
ar_check_init(gcl_cmpinline,no_init);
ar_check_init(gcl_cmputil,no_init);
ar_check_init(gcl_debug,no_init);
ar_check_init(gcl_info,no_init);
- ar_check_init(gcl_cmptype,no_init);
+/* ar_check_init(gcl_cmptype,no_init); */
ar_check_init(gcl_cmpbind,no_init);
ar_check_init(gcl_cmpblock,no_init);
ar_check_init(gcl_cmpcall,no_init);
Index: unixport/sys_pcl_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_pcl_gcl.c,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -b -r1.15 -r1.16
--- unixport/sys_pcl_gcl.c 5 Jun 2006 22:02:46 -0000 1.15
+++ unixport/sys_pcl_gcl.c 17 Jun 2006 19:26:58 -0000 1.16
@@ -108,13 +108,14 @@
/* ar_check_init(gcl_ansi_io,no_init); deleted by kraehe */
+ ar_check_init(gcl_cmptype,no_init);
ar_check_init(gcl_cmpinline,no_init);
ar_check_init(gcl_cmputil,no_init);
ar_check_init(gcl_debug,no_init);
ar_check_init(gcl_info,no_init);
- ar_check_init(gcl_cmptype,no_init);
+/* ar_check_init(gcl_cmptype,no_init); */
ar_check_init(gcl_cmpbind,no_init);
ar_check_init(gcl_cmpblock,no_init);
ar_check_init(gcl_cmpcall,no_init);
Index: unixport/sys_pre_gcl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/unixport/sys_pre_gcl.c,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -b -r1.11 -r1.12
--- unixport/sys_pre_gcl.c 5 Jun 2006 22:02:46 -0000 1.11
+++ unixport/sys_pre_gcl.c 17 Jun 2006 19:26:58 -0000 1.12
@@ -120,13 +120,14 @@
/* lsp_init("../mod/gcl_defpackage.lsp"); */
/* lsp_init("../mod/gcl_make_defpackage.lsp"); */
+ lsp_init("../cmpnew/gcl_cmptype.lsp");
lsp_init("../cmpnew/gcl_cmpinline.lsp");
lsp_init("../cmpnew/gcl_cmputil.lsp");
lsp_init("../lsp/gcl_debug.lsp");
lsp_init("../lsp/gcl_info.lsp");
- lsp_init("../cmpnew/gcl_cmptype.lsp");
+/* lsp_init("../cmpnew/gcl_cmptype.lsp"); */
lsp_init("../cmpnew/gcl_cmpbind.lsp");
lsp_init("../cmpnew/gcl_cmpblock.lsp");
lsp_init("../cmpnew/gcl_cmpcall.lsp");
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Gcl-commits] gcl omakefun.c debian/changelog cmpnew/gcl_cmpb...,
Camm Maguire <=