/[gcl]/gcl/lsp/gcl_predlib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_predlib.lsp

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

revision 1.30 by camm, Wed Oct 12 20:51:48 2005 UTC revision 1.31 by camm, Thu Oct 13 21:22:41 2005 UTC
# Line 47  Line 47 
47              `(,tp ,(upgraded-array-element-type (array-element-type object)))              `(,tp ,(upgraded-array-element-type (array-element-type object)))
48            tp))))            tp))))
49    
50    (defmacro dt-apply (x y)
51      (let ((l (gensym)))
52        `(let ((,l (length ,y)))
53           (case ,l
54                 (0 (funcall ,x))
55                 (1 (funcall ,x (car ,y)))
56                 (2 (funcall ,x (car ,y) (cadr ,y)))
57                 (otherwise (apply ,x ,y))))))
58    
59  (defun typep-int (object type &aux tp i tem)  (defun typep-int (object type &aux tp i tem)
60    (if (atom type)    (if (atom type)
61        (setq tp type i nil)        (setq tp type i nil)
# Line 124  Line 133 
133                    broadcast-stream two-way-stream echo-stream) (eq (type-of-c object) tp))                    broadcast-stream two-way-stream echo-stream) (eq (type-of-c object) tp))
134      (t (cond      (t (cond
135           ((setq tem (when (symbolp tp) (get tp 'deftype-definition)))           ((setq tem (when (symbolp tp) (get tp 'deftype-definition)))
136            (typep-int object (apply tem i)))            (typep-int object (dt-apply tem i)))
137           ((if (symbolp tp) (get tp 's-data) (typep-int tp 's-data))           ((if (symbolp tp) (get tp 's-data) (typep-int tp 's-data))
138            (let ((z (structure-subtype-p object tp))) z))            (let ((z (structure-subtype-p object tp))) z))
139           ((classp tp)           ((classp tp)
# Line 281  Line 290 
290     ((assert-type object type))))     ((assert-type object type))))
291    
292  ;;; DEFTYPE macro.  ;;; DEFTYPE macro.
293  (defmacro deftype (name lambda-list &rest body &aux decls)  (defmacro deftype (name lambda-list &rest body &aux decls prot)
294    ;; Replace undefaultized optional parameter X by (X '*).    ;; Replace undefaultized optional parameter X by (X '*).
295    (declare (optimize (safety 1)))    (declare (optimize (safety 1)))
296    (do ((b body body)) ((or (not b) (not (consp (car b))) (not (eq 'declare (caar b)))) (nreverse decls))    (do ((b body body)) ((or (not b) (not (consp (car b))) (not (eq 'declare (caar b)))) (nreverse decls))
# Line 291  Line 300 
300    (do ((l lambda-list (cdr l))    (do ((l lambda-list (cdr l))
301         (m nil (cons (car l) m)))         (m nil (cons (car l) m)))
302        ((null l))        ((null l))
303      (when (member (car l) lambda-list-keywords)        (cond ((member (car l) lambda-list-keywords)
304            (unless (member (car l) '(&optional &key)) (return nil))               (unless (eq (car prot) '*) (push '* prot))
305            (setq m (cons (car l) m))               (unless (member (car l) '(&optional &key)) (return nil))
306            (setq l (cdr l))               (setq m (cons (car l) m))
307            (do ()               (setq l (cdr l))
308                ((or (null l) (member (car l) lambda-list-keywords)))               (do ()
309              (if (symbolp (car l))                   ((or (null l) (member (car l) lambda-list-keywords)))
310                  (setq m (cons (list (car l) ''*) m))                   (if (symbolp (car l))
311                  (setq m (cons (car l) m)))                       (setq m (cons (list (car l) ''*) m))
312              (setq l (cdr l)))                     (setq m (cons (car l) m)))
313            (setq lambda-list (nreconc m l))                   (setq l (cdr l)))
314            (return nil)))               (setq lambda-list (nreconc m l))
315    `(eval-when (compile eval load)               (return nil))
316                (putprop ',name              ((push t prot))))
317                            '(deftype ,name ,lambda-list ,@body)    (let ((fun-name (gensym (string name))) (prot (nreverse prot)))
318                            'deftype-form)      `(eval-when (compile eval load)
319                (putprop ',name                  (putprop ',name
320                         (if (null ',lambda-list)                           '(deftype ,name ,lambda-list ,@body)
321                             (lambda nil ,@decls (block ,name ,`(progn ,@body)))                           'deftype-form)
322                           (lambda ,lambda-list ,@decls (block ,name ,@body)))                  (proclaim '(ftype (function ,prot t) ,fun-name))
323                            'deftype-definition)                  (defun ,fun-name ,lambda-list ,@decls (block ,name ,@body))
324                (putprop ',name                  (putprop ',name ',fun-name 'deftype-definition)
325                            ,(find-documentation body)                  (putprop ',name
326                            'type-documentation)                           ,(find-documentation body)
327                ',name))                           'type-documentation)
328                    ',name)))
329    
330  ;;; Some DEFTYPE definitions.  ;;; Some DEFTYPE definitions.
331  (deftype seqind ()  (deftype seqind ()
# Line 424  Line 434 
434  (deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high)))  (deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high)))
435  (deftype number () `(or real complex))  (deftype number () `(or real complex))
436  (deftype atom () `(not cons))  (deftype atom () `(not cons))
437  (deftype function (&optional as vs) `(or interpreted-function compiled-function generic-function))  (deftype function (&optional as vs)
438      (declare (ignore as vs))
439      `(or interpreted-function compiled-function generic-function))
440    
441  (deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high))  (deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high))
442  (deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high))  (deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high))
# Line 635  Line 647 
647  ;;FIXME loose the ar and default to t  ;;FIXME loose the ar and default to t
648  (defun normalize-type-int (type ar &aux tem)  (defun normalize-type-int (type ar &aux tem)
649    (cond ((atom type) (normalize-type-int (list type) ar))    (cond ((atom type) (normalize-type-int (list type) ar))
650          ;;These are deftype accelerators          ;;These are deftype accelerators  FIXME may no longer be necessary with faster deftype
651          ((member (car type) +range-types+)          ((member (car type) +range-types+)
652           (let* ((l (cadr type))           (let* ((l (cadr type))
653                  (ln (if (cdr type) (maybe-eval l) '*))                  (ln (if (cdr type) (maybe-eval l) '*))
# Line 682  Line 694 
694                          (mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x))                          (mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x))
695                                  (cdr type))                                  (cdr type))
696                        (cdr type)))                        (cdr type)))
697                  (nt (and dt (or (apply dt rr) '(nil)))))                  (nt (and dt (or (dt-apply dt rr) '(nil)))))
698             (when (and nt (not (equal type nt)))             (when (and nt (not (equal type nt)))
699               (normalize-type-int nt ar))))               (normalize-type-int nt ar))))
700          ((member (car type) '(and or not))          ((member (car type) '(and or not))

Legend:
Removed from v.1.30  
changed lines
  Added in v.1.31

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