/[gcl]/gcl/cmpnew/gcl_cmpfun.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpfun.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by camm, Wed Jun 29 04:16:35 2005 UTC revision 1.9 by camm, Sat Jul 23 08:47:45 2005 UTC
# Line 1  Line 1 
1    ;; -*-Lisp-*-
2  ;; CMPFUN  Library functions.  ;; CMPFUN  Library functions.
3  ;;;  ;;;
4  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
# Line 35  Line 36 
36  (si:putprop 'rplacd 'c1rplacd 'c1)  (si:putprop 'rplacd 'c1rplacd 'c1)
37  (si:putprop 'rplacd 'c2rplacd 'c2)  (si:putprop 'rplacd 'c2rplacd 'c2)
38    
39  (si:putprop 'si::memq 'c1memq 'c1)  ;(dolist (l '(si::memq
40  (si:putprop 'member 'c1member 'c1)  ;            member member-i member-if-not
41  (si:putprop 'member!2 'c2member!2 'c2)  ;            assoc assoc-i assoc-if-not
42  (si:putprop 'assoc 'c1assoc 'c1)  ;            rassoc rassoc-i rassoc-if-not
43  (si:putprop 'rassoc 'c1rassoc 'c1)  ;            intersection set-difference set-exclusive-or subsetp union))
44  (si:putprop 'assoc!2 'c2assoc!2 'c2)  ;  (si::putprop l (intern (concatenate 'string "C1" (symbol-name l))) 'c1))
45    
46    ;(si:putprop 'si::memq 'c1memq 'c1)
47    ;(si:putprop 'member 'c1member 'c1)
48    ;(si:putprop 'member-if 'c1member-if 'c1)
49    ;(si:putprop 'member-if-not 'c1member-if-not 'c1)
50    ;(si:putprop 'member!2 'c2member!2 'c2)
51    ;(si:putprop 'assoc 'c1assoc 'c1)
52    ;(si:putprop 'rassoc 'c1rassoc 'c1)
53    ;(si:putprop 'set-difference 'c1set-difference 'c1)
54    ;(si:putprop 'assoc!2 'c2assoc!2 'c2)
55    
56    
57  (si:putprop 'get 'c1get 'c1)  (si:putprop 'get 'c1get 'c1)
58  (si:putprop 'get 'c2get 'c2)  (si:putprop 'get 'c2get 'c2)
59    
# Line 51  Line 64 
64  (si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2)  (si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2)
65    
66  (defvar *princ-string-limit* 80)  (defvar *princ-string-limit* 80)
67    (defvar *type-alist*
68      '((fixnum . si::fixnump)
69        (float . floatp)
70        (short-float . short-float-p)
71        (long-float . long-float-p)
72        (integer . integerp)
73        (character . characterp)
74        (symbol . symbolp)
75        (cons . consp)
76        (null . null)
77        (array . arrayp)
78        (vector . vectorp)
79        (bit-vector . bit-vector-p)
80        (string . stringp)
81        (list . listp)
82        (number . numberp)
83        (rational . rationalp)
84        (complex . complexp)
85        (ratio . ratiop)
86        (sequence . (lambda (y) (or (listp y) (vectorp y))))
87        (function . functionp)
88        ))
89    
90  (defun c1princ (args &aux stream (info (make-info)))  (defun c1princ (args &aux stream (info (make-info)))
91    (when (endp args) (too-few-args 'princ 1 0))    (when (endp args) (too-few-args 'princ 1 0))
# Line 230  Line 265 
265    
266  (defun c1funcall (args &aux funob (info (make-info)))  (defun c1funcall (args &aux funob (info (make-info)))
267    (when (endp args) (too-few-args 'funcall 1 0))    (when (endp args) (too-few-args 'funcall 1 0))
268    (setq funob (c1funob (car args)))    (cond ((and (consp (car args)) (eq (caar args) 'lambda))
269    (add-info info (cadr funob))           (c1lambda-fun (cdar args) (cdr args)))
270    (list 'funcall info funob (c1args (cdr args) info))          ((and (consp (car args)) (eq (caar args) 'function) (symbolp (cadar args)) (not (cddar args)))
271    )           (c1expr `(,(cadar args) ,@(cdr args))))
272            ((constantp (car args))
273             (c1expr `(,(cmp-eval (car args)) ,@(cdr args))))
274            ((progn
275               (setq funob (c1funob (car args)))
276               (add-info info (cadr funob))
277               (list 'funcall info funob (c1args (cdr args) info))))))
278    
279  (defun c1rplaca (args &aux (info (make-info)))  (defun c1rplaca (args &aux (info (make-info)))
280    (when (or (endp args) (endp (cdr args)))    (when (or (endp args) (endp (cdr args)))
# Line 277  Line 317 
317  (defconstant +ifr+ (ash (- +ifb+)  -1))  (defconstant +ifr+ (ash (- +ifb+)  -1))
318  (defconstant +ift+ '(integer #.(- +ifr+) #.(1- +ifr+)))  (defconstant +ift+ '(integer #.(- +ifr+) #.(1- +ifr+)))
319    
320    ;;FIXME the right way to do these is by defining compound types and
321    ;;using typep and subtypep -- alas these choke on these types of forms
322    ;;at the moment. 20050704 CM
323    
324  (defun eql-is-eq (x)  (defun eql-is-eq (x)
325    (cond ((typep x '#.+ift+))    (cond ((typep x '#.+ift+))
326          ((or (typep x 'number) (typep x 'character)) nil)          ((member-if (lambda (y) (typep x y)) '(number character)) nil)
327          (t)))          (t)))
328    
329  (defun eql-is-eq-tp (x)  (defun eql-is-eq-tp (x)
330    (cond ((subtypep x +ift+))    (cond ((subtypep x +ift+) (values t t))
331          ((or (subtypep x 'number) (subtypep x 'character)) nil)          ((subtypep +ift+ x) (values nil nil))
332          ((or (subtypep 'number x) (subtypep 'character x)) nil)          ((member-if (lambda (y) (subtypep x y)) '(number character)) (values nil t))
333          (t)))          (t (values t t))))
334    
335  (defun implicit-eq-tst (item list)  (defun equal-is-eq (x)
336    (cond ((and (constantp item) (eql-is-eq item)))    (cond ((member-if (lambda (y) (typep x y)) '(cons string bit-vector pathname)) nil)
337          ((and (constantp list) (consp list) (consp (cadr list))          ((eql-is-eq x))))
338                (reduce (lambda (x y) (and (eql-is-eq x) y)) (cadr list))))  
339          ((let* ((info (make-info))  (defun equal-is-eq-tp (x)
340                  (nargs (c1args (list item list) info)))    (cond ((member-if (lambda (y) (subtypep x y)) '(cons string bit-vector pathname)) (values nil t))
341             (eql-is-eq-tp (info-type (cadar nargs)))))))          (t (eql-is-eq-tp x))))
342      
343  (defun lit-fun (x &rest r)  (defun equalp-is-eq (x)
344    (cond ((atom x) `(funcall ,x ,@r))    (cond ((member-if (lambda (y) (typep x y)) '(array hash-table structure number)) nil)
345          ((member (car x) '(quote function)) `(,(cadr x) ,@r))          ((equal-is-eq x))))
346          ((eq (car x) 'lambda) `(,x ,@r))  
347          ((wfs-error))))  (defun equalp-is-eq-tp (x)
348      (cond ((member-if (lambda (y) (subtypep x y)) '(array hash-table structure number)) (values nil t))
349  (defun do-list-srch (item list tst key k1 ret)          (t (equal-is-eq-tp x))))
350    (let* ((key-form `(,k1 ,list))  
351           (key-form (if key (lit-fun key key-form) key-form))  (defun do-eq-et-al (fn args)
352           (tst-form (lit-fun tst item key-form))    (let* ((tf (cadr (test-to-tf fn)))
353           (tst-form (if ret `(and (,ret ,list) ,tst-form) tst-form))           (info (make-info))
354           (exit-form `(or (not ,list) ,tst-form))           (nargs (c1args args info)))
355           (ret-form (if ret `(,ret ,list) list)))      (cond ((and tf
356      `(do ((,list ,list (cdr ,list)))                  (or (funcall tf (info-type (cadar nargs)))
357           (,exit-form ,ret-form))))                      (funcall tf (info-type (cadadr nargs)))))
358               (list 'call-global info 'eq nargs))
359  (defun fun-to-sym (x)            ((list 'call-global info fn nargs)))))
360    (if (and (consp x) (or (eq (car x) 'quote) (eq (car x) 'function)))            
361        (cadr x)  (dolist (l `(eq eql equal equalp))
362      x))    (si::putprop l 'do-eq-et-al 'c1g))
363    
364  (defun do-list-srch-eql (item list tst key k1 ret)  (defun num-type-bounds (t1)
365    (let ((ei (gensym)) (el (gensym)))    (let ((t1 (si::normalize-type t1))
366      `(let ((,ei ,item) (,el ,list))          (i 1) j)
367         ,(if (eq (fun-to-sym tst) 'eql)      (mapcar (lambda (x)
368             `(if (eql-is-eq ,ei)                (setq j i i (- i)
369                  ,(do-list-srch ei el ''eq key k1 ret)                      x (cond ((atom x) x)
370                ,(do-list-srch ei el tst key k1 ret))                              ((and (eq (car t1) 'integer) (integerp (car x))) (+ (car x) j))
371           (do-list-srch ei el tst key k1 ret)))))                              ((car x))))) (cdr t1))))
372    
373  (defun list-expr (item list &key key test test-not k1 ret)  
374    (when (and test test-not)  (defun num-type-rel (fn t1 t2 &optional s)
375      (error ":test and :test-not both specified"))    (let ((nop (car (rassoc fn '((>= . <) (> . <=) (= . /=)))))
376    (let ((test (or test          (rfn (cdr (assoc fn '((>= . >) (> . >=))))))
377                   (and test-not `(lambda (x y) (not ,(lit-fun test-not 'x 'y))))      (cond (nop (let ((q (num-type-rel nop t1 t2)))
378                   (if (implicit-eq-tst item list) ''eq ''eql))))                   (list (and (not (car q)) (cadr q)) (cadr q))))
379      (c1expr (do-list-srch-eql item list test key k1 ret))))            ((eq fn '=) (mapcar (lambda (x y) (and x y)) (num-type-rel '>= t1 t2) (num-type-rel '>= t2 t1)))
380              ((not s) (let ((f (num-type-rel fn t1 t2 t)))
381  (defmacro with-item-list-keys ((item list keys) args &body body)                       (list f (or f (num-type-rel rfn t2 t1 t)))))
382    `(let ((,item (car ,args)) (,list (cadr ,args)) (,keys (cddr ,args)))            ((let ((t1 (car (num-type-bounds t1)))
383       (when (or (endp ,args) (endp (cdr ,args)))                   (t2 (cadr (num-type-bounds t2))))
384         (too-few-args 'list-expr 2 (length ,args)))                 (and (numberp t1) (numberp t2) (funcall fn t1 t2)))))))
385       ,@body))  
386    
387  (defun c1assoc (args)  (defun do-num-relations (fn args)
388    (with-item-list-keys    (let* ((info (make-info))
389     (item list keys) args           (nargs (c1args args info))
390     (apply 'list-expr item list :k1 'caar :ret 'car keys)))           (t1 (and (cddr args) (info-type (cadar nargs))))
391  (defun c1rassoc (args)           (t2 (and (cddr args) (info-type (cadadr nargs))))
392    (with-item-list-keys           (r (and t1 t2 (num-type-rel fn t1 t2))))
393     (item list keys) args      (cond ((cddr args) (list 'call-global info fn nargs))
394     (apply 'list-expr item list :k1 'cdar :ret 'car keys)))            ((car r) (c1expr t))
395  (defun c1member (args)            ((cadr r) (c1expr nil))
396    (with-item-list-keys            ((list 'call-global info fn nargs)))))
397     (item list keys) args  
398    (apply 'list-expr item list  :k1 'car keys)))  (dolist (l `(>= > < <= = /=))
399  (defun c1memq (args)    (si::putprop l 'do-num-relations 'c1g))
400    (with-item-list-keys  
401     (item list keys) args  (dolist (l `(eq eql equal equalp > >= < <= = /=
402    (apply 'list-expr item list :k1 'car :test ''eq keys)))                  ,@(mapcar (lambda (x) (cdr x)) (remove-if-not (lambda (x) (symbolp (cdr x))) *type-alist*))))
403      (si::putprop l t 'c1no-side-effects))
404  ;;FIXME member-if member-if-not et.al by ;test -> :test-not  
405    ;;bound type comparisons
406    ;; only boolean eval const args
407    
408    
409    
410    
411    (defun list-tp-test (tf lt)
412      (cond ((null lt) (values t t))
413            ((atom lt) (values nil nil))
414            ((eq (car lt) 'cons)
415             (multiple-value-bind
416              (m1 f1) (funcall tf (cadr lt))
417              (multiple-value-bind
418               (m2 f2) (list-tp-test tf (caddr lt))
419               (values (and m1 m2) (or f1 f2)))))
420            (t (values nil nil))))
421    
422    (defun test-to-tf (test)
423      (let ((test (if (constantp test) (cmp-eval test) test)))
424        (cond ((member test `(eql ,#'eql)) '(eql-is-eq eql-is-eq-tp))
425              ((member test `(equal ,#'equal)) '(equal-is-eq equal-is-eq-tp))
426              ((member test `(equalp ,#'equalp)) '(equalp-is-eq equalp-is-eq-tp)))))
427    
428    (defun is-eq-test-item-list (test item list)
429      (declare (ignore list))
430      (let ((tf (car (test-to-tf test))))
431        (and tf (funcall tf item))))
432            
433    (defun c1is-eq-test-item-list (args)
434      (let* ((ltf (test-to-tf (car args)))
435             (tf (cadr ltf))
436             (info (make-info)))
437        (if (not tf)
438            (c1expr nil)
439          (let ((nargs (c1args (cdr args) info)))
440            (multiple-value-bind
441             (m1 f1) (funcall tf (info-type (cadar nargs)))
442             (multiple-value-bind
443              (m2 f2) (list-tp-test tf (info-type (cadadr nargs)))
444              (declare (ignore f2))
445              (cond ((or m1 m2) (c1expr t))
446                    (f1 (c1expr nil))
447                    ((let ((info (make-info))) (list 'call-global info (car ltf) (c1args (list (cadr args)) info)))))))))))
448    (si::putprop 'is-eq-test-item-list 'c1is-eq-test-item-list 'c1)
449    
450    (defun do-predicate (fn args)
451      (let* ((info (make-info))
452            (nargs (c1args args info))
453            (tp (car (rassoc fn *type-alist*))))
454        (let ((at (and (not (cdr args)) (info-type (cadar nargs)))))
455          (cond ((and at (subtypep at tp)) (c1expr t))
456                ((not (type-and at tp)) (c1expr nil))
457                ((list 'call-global info fn nargs))))))
458    (dolist (l *type-alist*) (when (symbolp (cdr l)) (si::putprop (cdr l) 'do-predicate 'c1g)))
459    
460    (defun c1or (args)
461      (cond ((null args) (c1expr nil))
462            ((constantp (car args)) (let ((na (cmp-eval (car args)))) (if na (c1expr na) (c1or (cdr args)))))
463            ((null (cdr args)) (c1expr (car args)))
464            ((macro-function 'or) (c1expr (cmp-macroexpand `(or ,@args))))
465            ((let ((info (make-info))) (list 'call-global info 'or (c1args args info))))))
466    (si::putprop 'or 'c1or 'c1)
467    
468    (defun cmp-array-element-type (&rest args)
469      (and
470       args
471       (let ((z (or (not (typep (car args) 'array)) (upgraded-array-element-type (array-element-type (car args)))))
472             (y (apply 'cmp-array-element-type (cdr args))))
473         ;;need type-or here
474         (cond ((subtypep z y) y)
475               ((subtypep y z) z)
476               (t)))))
477    
478    (defun array-element-subtype (type)
479      (let ((type (si::normalize-type type)))
480        (or
481         (not (consp type))
482         (not (member (car type) '(array simple-array)))
483         (null (cadr type))
484         (eq (cadr type) '*)
485         (cadr type))))
486    
487    (defun cmp-array-element-subtype (args)
488      (and
489       args
490       (let ((z (array-element-subtype (car args)))
491             (y (cmp-array-element-subtype (cdr args))))
492         ;;need type-or here
493         (cond ((subtypep z y) y)
494               ((subtypep y z) z)
495               (t)))))
496    
497    (defun c1cmp-array-element-type (args)
498      (let* ((info (make-info))
499             (nargs (c1args args info)))
500        (c1expr `(quote ,(cmp-array-element-subtype (mapcar (lambda (x) (info-type (cadr x))) nargs))))))
501    (si::putprop 'cmp-array-element-type 'c1cmp-array-element-type 'c1)
502    
503    (defun cons-type-length (type)
504      (cond ((null type) 0)
505            ((and (consp type) (eq (car type) 'cons)) (+ 1 (cons-type-length (caddr type))))))
506    
507    (defun c1make-array (args)
508      (let* ((info (make-info))
509             (nargs (c1args args info)))
510        (let* ((eltp (position :element-type args))
511               (eltp (and eltp (nth (1+ eltp) nargs)))
512               (eltp (and eltp (consp eltp) (eq (car eltp) 'location) (caddr eltp)))
513               (eltp (and (consp eltp) (eq (car eltp) 'VV) (caar (member (cadr eltp) *objects*  :key 'cadr))))
514               (eltp (if eltp `(,eltp) `(*))))
515          (let ((szf (let ((st (info-type (cadar nargs))))
516                       (cond ((subtypep st 'list) `(,(make-list (cons-type-length st) :initial-element '*)))
517                             ((and st (not (subtypep 'list st))) `((*)))))))
518            (setf (info-type info) `(array ,@eltp ,@szf))
519            (list 'call-global info 'make-array nargs)))))
520    (si::putprop 'make-array 'c1make-array 'c1)
521    
522    ;(defun all-type (types type)
523    ;  (if (null types)
524    ;      (values t nil)
525    ;    (let ((m (subtypep (car types) type))
526    ;         (f (subtypep type (car types))))
527    ;      (multiple-value-bind
528    ;       (m1 f1)(all-type (cdr types) type)
529    ;        (values (and m m1) (or (and (not m) (not f)) f1))))))
530        
531    ;(defun all-type-check (fn type pred args)
532    ;  (let* ((info (make-info))
533    ;       (nargs (c1args args info)))
534    ;    (multiple-value-bind
535    ;     (m f) (all-type (mapcar (lambda (x) (info-type (cadr x))) nargs) type)
536    ;     (cond (m (c1expr t))
537    ;          (f (c1expr nil))
538    ;          ((c1expr (reduce (lambda (x y) `(and ,x (,pred ,y))) args :initial-value t)))))))
539    
540    ;(defun all-lists (args)
541    ;  (every 'listp args))
542    ;(defun c1all-lists (args)
543    ;  (all-type-check 'all-lists 'list 'listp args))
544    ;(si::putprop 'all-lists 'c1all-lists 'c1)
545    ;(defun all-vectors (args)
546    ;  (every 'vectorp args))
547    ;(defun c1all-vectors (args)
548    ;  (all-type-check 'all-vectors 'vector 'vectorp args))
549    ;(si::putprop 'all-vectors 'c1all-vectors 'c1)
550    
551  (defun boole3 (a b c)  (boole a b c))  (defun boole3 (a b c)  (boole a b c))
552  (si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional)  (si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional)
# Line 517  Line 706 
706          (t t)))          (t t)))
707    
708    
709    ;(defvar *std-instance-class-type* nil)
710  (defvar *type-alist*  ;(defvar *std-instance-symbol* nil)
   '((fixnum . si::fixnump)  
     (float . floatp)  
     (short-float . short-float-p)  
     (long-float . long-float-p)  
     (integer . integerp)  
     (character . characterp)  
     (symbol . symbolp)  
     (cons . consp)  
     (null . null)  
     (array . arrayp)  
     (vector . vectorp)  
     (bit-vector . bit-vector-p)  
     (string . stringp)  
     (list . (lambda (y) (or (consp y) (null y))))  
     (number . numberp)  
     (rational . rationalp)  
     (complex . complexp)  
     (ratio . ratiop)  
     (sequence . (lambda (y) (or (listp y) (vectorp y))))  
     (function . functionp)  
     ))  
   
711    
712  (defun co1typep (f args &aux tem) f  (defun co1typep (f args &aux tem) f
713    (let*    (let* ((x (car args))  new
714        ((x (car args))  new           (type (and (literalp (cadr args)) (cmp-eval (cadr args)))))
715         (type (and (consp (second args))  ;    (unless *std-instance-symbol*
716                    (eq (car (second args)) 'quote)  ;      (setq *std-instance-symbol* (let ((p (find-package 'pcl))) (and p (find-symbol "STD-INSTANCE" p)))))
717                    (second (second args)))))  ;    (when (eq type *std-instance-symbol*)
718      (cond ((subtypep (result-type (car args)) type)  ;      (unless *std-instance-class-type*
719             (setq new t)  ;       (let* ((p (find-package 'pcl))
720             (return-from co1typep (c1expr new))))  ;              (s (and p (find-symbol "SLOT-OBJECT" p)))
721    ;              (si (and s (import s 'compiler)))
722    ;              (q (and p (find-symbol "FUNCALLABLE-STANDARD-OBJECT" p)))
723    ;              (qi (and q (import q 'compiler))))
724    ;         (when (and si qi)
725    ;           (setq *std-instance-class-type* `(and ,s (not ,q)))))))
726    ;    (let ((type (or (and (eq type *std-instance-symbol*) *std-instance-class-type*) type)))
727          (let ((rt (result-type (car args))))
728    ;       (format t "~a ~a ~a ~a ~a ~a~%" type rt (car args) (subtypep rt type) (multiple-value-list (subtypep type rt)) (type-and type rt))
729            (cond ((subtypep rt type)
730                   (setq new t)
731                   (return-from co1typep (c1expr new)))
732                  ((and type (multiple-value-bind (m v) (subtypep type rt) (and (not m) v)) (not (type-and type rt)))
733                   (setq new nil)
734                   (return-from co1typep (c1expr new)))))
735    ;)
736      (setq new      (setq new
737            (cond            (cond
738             ((null type) nil)             ((null type) nil)
# Line 921  Line 1103 
1103    
1104        
1105  ;; end new                  ;; end new                
1106    
1107    (defun c1list (args)
1108      (let* ((info (make-info))
1109            (nargs (c1args args info)))
1110        (setf (info-type info) (nil-to-t (reduce (lambda (x y) (list 'cons (info-type (cadr x)) y)) (append nargs '(nil)) :from-end t)))
1111        (list 'call-global info 'list nargs)));
1112    (si::putprop 'list 'c1list 'c1)
1113                
1114  (defun c1list-nth (args &aux (info (make-info)))  (defun c1list-nth (args &aux (info (make-info)))
1115    (when (or (endp args) (endp (cdr args)))    (when (or (endp args) (endp (cdr args)))

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26