[Gcl-commits] gcl debianchangelog cmpnew/gcl_cmpflet.lsp cmpn...

[Camm Maguire]

CVSROOT:        /cvsroot/gcl
Module name:    gcl
Changes by:     Camm Maguire <camm>     06/06/09 20:50:58

Modified files:
        debian         : changelog 
        cmpnew         : gcl_cmpflet.lsp gcl_cmpmulti.lsp gcl_cmptop.lsp 
                         gcl_cmptype.lsp 
        lsp            : gcl_setf.lsp 

Log message:
        Fix typing bug in c1flet/c1labels,make (values form) an efficient 
return,portable code turns &aux into let* to make the lambda 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)

CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/gcl/debian/changelog?cvsroot=gcl&r1=1.1088&r2=1.1089
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpflet.lsp?cvsroot=gcl&r1=1.14&r2=1.15
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpmulti.lsp?cvsroot=gcl&r1=1.20&r2=1.21
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmptop.lsp?cvsroot=gcl&r1=1.36&r2=1.37
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmptype.lsp?cvsroot=gcl&r1=1.33&r2=1.34
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_setf.lsp?cvsroot=gcl&r1=1.18&r2=1.19

Patches:
Index: debian/changelog
===================================================================
RCS file: /cvsroot/gcl/gcl/debian/changelog,v
retrieving revision 1.1088
retrieving revision 1.1089
diff -u -b -r1.1088 -r1.1089
--- debian/changelog    8 Jun 2006 18:54:08 -0000       1.1088
+++ debian/changelog    9 Jun 2006 20:50:57 -0000       1.1089
@@ -175,8 +175,13 @@
   * fix read-char-no-hang
   * string comparison functions are not predicates
   * first automatic state function for mutual recursion support
+  * Fix typing bug in c1flet/c1labels,make (values form) an efficient
+    return,portable code turns &aux into let* to make the lambda
+    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)
 
- -- Camm Maguire <address@hidden>  Thu,  8 Jun 2006 18:53:52 +0000
+ -- Camm Maguire <address@hidden>  Fri,  9 Jun 2006 20:50:39 +0000
 
 gclcvs (2.7.0-53) unstable; urgency=low
 

Index: cmpnew/gcl_cmpflet.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpflet.lsp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -b -r1.14 -r1.15
--- cmpnew/gcl_cmpflet.lsp      5 Jun 2006 22:21:08 -0000       1.14
+++ cmpnew/gcl_cmpflet.lsp      9 Jun 2006 20:50:58 -0000       1.15
@@ -152,7 +152,7 @@
     (let ((*vars* *vars*))
       (with-restore-vars
        (mapc (lambda (x) (when (and (var-p x) (or (var-ref-ccb x) (eq 'clb 
(var-loc x))))
-                          (push (list x (var-type x)) *restore-vars*)
+;                         (push (list x (var-type x)) *restore-vars*)
                           (setf (var-type x) (var-dt x)))) *vars*)
        (c1add-globals ss)
        (check-vdecl nil ts is)
@@ -297,7 +297,7 @@
   (let ((*vars* *vars*))
     (with-restore-vars
      (mapc (lambda (x) (when (and (var-p x) (or (var-ref-ccb x) (eq 'clb 
(var-loc x))))
-                        (push (list x (var-type x)) *restore-vars*)
+;                       (push (list x (var-type x)) *restore-vars*)
                         (setf (var-type x) (var-dt x)))) *vars*)
      (c1add-globals ss)
      (check-vdecl nil ts is)

Index: cmpnew/gcl_cmpmulti.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpmulti.lsp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -b -r1.20 -r1.21
--- cmpnew/gcl_cmpmulti.lsp     5 Jun 2006 22:02:45 -0000       1.20
+++ cmpnew/gcl_cmpmulti.lsp     9 Jun 2006 20:50:58 -0000       1.21
@@ -110,15 +110,15 @@
   )
 
 (defun c1values (args &aux (info (make-info)))
-      (cond ((and args (not (cdr args))
-                 (or (not (consp (car args)))
-                     (and (symbolp (caar args))
-                          (let ((tem (get-return-type (caar args))))
-                            (and tem
-                                 (or (atom tem)
-                                     (and (consp tem)
-                                          (null (cdr tem))
-                                          (not (eq '* (car tem))))))))))
+      (cond ((and args (not (cdr args)))
+;                (or (not (consp (car args)))
+;                    (and (symbolp (caar args))
+;                         (let ((tem (get-return-type (caar args))))
+;                           (and tem
+;                                (or (atom tem)
+;                                    (and (consp tem)
+;                                         (null (cdr tem))
+;                                         (not (eq '* (car tem))))))))))
             ;;the compiler put in unnecessary code
             ;;if we just had say (values nil)
             ;; so if we know there's one value only:

Index: cmpnew/gcl_cmptop.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmptop.lsp,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -b -r1.36 -r1.37
--- cmpnew/gcl_cmptop.lsp       8 Jun 2006 18:54:09 -0000       1.36
+++ cmpnew/gcl_cmptop.lsp       9 Jun 2006 20:50:58 -0000       1.37
@@ -570,6 +570,22 @@
 
 (defvar *recursion-detected*)
 
+(defun aux-decls (auxs decls)
+  (let (ad dd)
+    (dolist (l decls)
+      (let* ((b (cadr l))
+            (b (if (eq (car b) 'type) (cdr b) b)))
+       (cond ((eq (car b) 'optimize) (push l dd))
+             ((let ((tt (intersection (cdr b) auxs)))
+                (cond ((not tt) (push l dd))
+                      ((let ((z (if (eq b (cadr l)) (list (caadr l)) (list 
(caadr l) (cadadr l)))))
+                         (push `(declare (,@z ,@tt)) ad)
+                         (let ((q (set-difference (cdr b) auxs)))
+                           (when q
+                             (push `(declare (,@z ,@q)) dd)))))))))))
+    (list (nreverse ad) (nreverse dd))))
+
+
 (defun t1defun (args &aux (setjmps *setjmps*) (defun 'defun) (*sharp-commas* 
nil) fname lambda-expr cfun doc)
   (when (or (endp args) (endp (cdr args)))
         (too-few-args 'defun 2 (length args)))
@@ -706,14 +722,17 @@
         (when (and (consp args) (stringp (car args))) (push (pop args) doc))
         (do nil ((or (not args) (not (consp (car args))) (not (eq (caar args) 
'declare))))
             (push (pop args) decls))
-        (push (cons fname (pd `(lambda ,ll
+        (let* ((nal (do (r (y ll)) ((or (not y) (eq (car y) '&aux)) (nreverse 
r)) (push (pop y) r)))
+               (al (cdr (member '&aux ll)))
+               (dd (aux-decls (mapcar (lambda (x) (if (atom x) x (car x))) al) 
decls)))
+        (push (cons fname (pd `(lambda ,nal
                                  ,@doc
                                  (declare (optimize (safety ,(cond 
(*compiler-push-events* 3)
                                                                    
(*safe-compile* 2)
                                                                    
(*compiler-check-args* 1)
                                                                    (0)))))
-                                 ,@(nreverse decls)
-                                 (block ,fname ,@args)))) *portable-source*))))
+                                 ,@(nreverse (cadr dd))
+                                 (block ,fname (let* ,al ,@(car dd) 
,@args))))) *portable-source*)))))
 
 (defun make-inline-string (cfun args fname)
   (if (null args)

Index: cmpnew/gcl_cmptype.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmptype.lsp,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -b -r1.33 -r1.34
--- cmpnew/gcl_cmptype.lsp      5 Jun 2006 22:02:45 -0000       1.33
+++ cmpnew/gcl_cmptype.lsp      9 Jun 2006 20:50:58 -0000       1.34
@@ -77,6 +77,7 @@
 (defvar *and-tp-hash* (make-hash-table :test 'equal))
 (defvar *or-tp-hash* (make-hash-table :test 'equal))
 
+
 (defun cmp-norm-tp (tp)
   (multiple-value-bind 
    (r f) 
@@ -564,6 +565,8 @@
               (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)
        ((subtypep1 type1 type2) type2)

Index: lsp/gcl_setf.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_setf.lsp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -b -r1.18 -r1.19
--- lsp/gcl_setf.lsp    5 Jun 2006 22:02:45 -0000       1.18
+++ lsp/gcl_setf.lsp    9 Jun 2006 20:50:58 -0000       1.19
@@ -620,6 +620,16 @@
        (prog1 (car ,access-form)
               ,store-form))))
 
+(defun fdefinition (name)
+  (declare (optimize (safety 1)))
+  (check-type name function-identifier)
+  (cond ((symbolp name) (values (symbol-function name)))
+       ((let ((z (get (cadr name) 'setf-function)))
+          (cond ((not z) (error :undefined-function "function ~s is undefined" 
name))
+                ((functionp z) z)
+                ((fdefintion z)))))))
+                
+
 (defun (setf fdefinition) (def fn)
   (declare (optimize (safety 1)))
   (when (not (functionp def))