/[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.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
1    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
2    
3    ;; This file is part of GNU Common Lisp, herein referred to as GCL
4    ;;
5    ;; GCL is free software; you can redistribute it and/or modify it under
6    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7    ;; the Free Software Foundation; either version 2, or (at your option)
8    ;; any later version.
9    ;;
10    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
11    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
13    ;; License for more details.
14    ;;
15    ;; You should have received a copy of the GNU Library General Public License
16    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
17    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
18    
19    
20    ;;;;    predlib.lsp
21    ;;;;
22    ;;;;                              predicate routines
23    
24    
25    (in-package 'system)
26    
27    (export '(lisp::deftype lisp::typep lisp::subtypep lisp::coerce) 'lisp)
28    
29    (eval-when (compile)
30    (proclaim '(optimize (safety 2) (space 3)))
31    )
32    
33    ;;; DEFTYPE macro.
34    (defmacro deftype (name lambda-list &rest body)
35      ;; Replace undefaultized optional parameter X by (X '*).
36      (do ((l lambda-list (cdr l))
37           (m nil (cons (car l) m)))
38          ((null l))
39        (when (member (car l) lambda-list-keywords)
40              (unless (eq (car l) '&optional) (return nil))
41              (setq m (cons '&optional m))
42              (setq l (cdr l))
43              (do ()
44                  ((or (null l) (member (car l) lambda-list-keywords)))
45                (if (symbolp (car l))
46                    (setq m (cons (list (car l) ''*) m))
47                    (setq m (cons (car l) m)))
48                (setq l (cdr l)))
49              (setq lambda-list (nreconc m l))
50              (return nil)))
51      `(eval-when (compile eval load)
52                  (si:putprop ',name
53                              '(deftype ,name ,lambda-list ,@body)
54                              'deftype-form)
55                  (si:putprop ',name
56                              #'(lambda ,lambda-list ,@body)
57                              'deftype-definition)
58                  (si:putprop ',name
59                              ,(find-documentation body)
60                              'type-documentation)
61                  ',name))
62    
63    
64    ;;; Some DEFTYPE definitions.
65    (deftype fixnum ()
66      `(integer ,most-negative-fixnum ,most-positive-fixnum))
67    (deftype bit () '(integer 0 1))
68    (deftype mod (n)
69      `(integer 0 ,(1- n)))
70    (deftype signed-byte (&optional s)
71      (if (eq s '*)
72          `(integer * *)
73          `(integer ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s))))))
74    (deftype unsigned-byte (&optional s)
75      (if (eq s '*)
76          `(integer 0 *)
77          `(integer 0 ,(1- (expt 2 s)))))
78    (deftype signed-char ()`(signed-byte ,char-size))
79    (deftype unsigned-char ()`(unsigned-byte ,char-size))
80    (deftype signed-short ()`(signed-byte ,short-size))
81    (deftype unsigned-short ()`(unsigned-byte ,short-size))
82    
83    
84    
85    (deftype vector (&optional element-type size)
86      `(array ,element-type (,size)))
87    (deftype string (&optional size)
88      `(vector string-char ,size))
89    (deftype base-string (&optional size)
90      `(vector base-char ,size))
91    (deftype bit-vector (&optional size)
92      `(vector bit ,size))
93    
94    (deftype simple-vector (&optional size)
95      `(simple-array t (,size)))
96    (deftype simple-string (&optional size)
97      `(simple-array string-char (,size)))
98    (deftype simple-base-string (&optional size)
99      `(simple-array base-char (,size)))
100    (deftype simple-bit-vector (&optional size)
101      `(simple-array bit (,size)))
102    
103    
104    
105    (defun simple-array-p (x)
106      (and (arrayp x)
107           ;; should be (not (expressly-adjustable-p x))
108           ;; since the following will always return T
109           ;; (not (adjustable-array-p x))
110           (not (array-has-fill-pointer-p x))
111           (not (si:displaced-array-p x))))
112    
113    
114    (do ((l '((null . null)
115              (symbol . symbolp)
116              (keyword . keywordp)
117              (atom . atom)
118              (cons . consp)
119              (list . listp)
120              (number . numberp)
121              (character . characterp)
122              (package . packagep)
123              (stream . streamp)
124              (pathname . pathnamep)
125              (readtable . readtablep)
126              (hash-table . hash-table-p)
127              (random-state . random-state-p)
128              (structure . si:structurep)
129              (function . functionp)
130              (compiled-function . compiled-function-p)
131              (common . commonp)
132              )
133            (cdr l)))
134        ((endp l))
135      (si:putprop (caar l) (cdar l) 'type-predicate))
136    
137    (defun class-of (object)
138      (declare (ignore object))
139      nil)
140    (defun classp (object)
141      (declare (ignore object))
142      nil)
143    (defun class-precedence-list (object)
144      (declare (ignore object))
145      nil)
146    (defun find-class (object)
147      (declare (ignore object))
148      nil)
149    
150    ;;; TYPEP predicate.
151    ;;; FIXME --optimize with most likely cases first
152    (defun typep (object type &optional env &aux tp i tem)
153      (declare (ignore env))
154      (when (classp type)
155        (return-from typep (if (member type (class-precedence-list (funcall 'class-of object))) t nil)))
156      (if (atom type)
157          (setq tp type i nil)
158          (setq tp (car type) i (cdr type)))
159      (if (eq tp 'structure-object) (setq tp 'structure))
160      (let ((f (get tp 'type-predicate)))
161        (when f (return-from typep (funcall f object))))
162      (case tp
163        (member (member object i))
164        (not (not (typep object (car i))))
165        (or
166         (do ((l i (cdr l)))
167             ((null l) nil)
168          (when (typep object (car l)) (return t))))
169        (and
170         (do ((l i (cdr l)))
171             ((null l) t)
172           (unless (typep object (car l)) (return nil))))
173        (satisfies (funcall (car i) object))
174        ((t) t)
175        ((nil) nil)
176        (boolean (or (eq object 't) (eq object 'nil)))
177        (fixnum (eq (type-of object) 'fixnum))
178        (bignum (eq (type-of object) 'bignum))
179        (ratio (eq (type-of object) 'ratio))
180        (standard-char
181         (and (characterp object) (standard-char-p object)))
182        ((base-char string-char)
183         (and (characterp object) (string-char-p object)))
184        (integer
185         (and (integerp object) (in-interval-p object i)))
186        (rational
187         (and (rationalp object) (in-interval-p object i)))
188        (real
189         (and (realp object) (in-interval-p object i)))
190        (float
191         (and (floatp object) (in-interval-p object i)))
192        ((short-float)
193         (and (eq (type-of object) 'short-float) (in-interval-p object i)))
194        ((single-float double-float long-float)
195         (and (eq (type-of object) 'long-float) (in-interval-p object i)))
196        (complex
197         (and (complexp object)
198        (or (null i)
199           (and   (typep (realpart object) (car i))
200                ;;wfs--should only have to check one.
201                ;;Illegal to mix real and imaginary types!
202                  (typep (imagpart object) (car i))))
203         ))
204        (sequence (or (listp object) (vectorp object)))
205        ((base-string string) ;FIXME
206         (and (stringp object)
207              (or (endp i) (match-dimensions (array-dimensions object) i))))
208        (bit-vector
209         (and (bit-vector-p object)
210              (or (endp i) (match-dimensions (array-dimensions object) i))))
211        ((simple-base-string simple-string) ;FIXME
212         (and (simple-string-p object)
213              (or (endp i) (match-dimensions (array-dimensions object) i))))
214        (simple-bit-vector
215         (and (simple-bit-vector-p object)
216              (or (endp i) (match-dimensions (array-dimensions object) i))))
217        (simple-vector
218         (and (simple-vector-p object)
219              (or (endp i) (eq (car i) '*)
220                  (and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object)))
221                  (equal (array-element-type object) (best-array-element-type (car i))))
222              (or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i)))))
223        (vector
224         (and (vectorp object)
225              (or (endp i) (eq (car i) '*)
226                  (and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object)))
227                  (equal (array-element-type object) (best-array-element-type (car i))))
228              (or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i)))))
229        (simple-array
230         (and (simple-array-p object)
231              (or (endp i) (eq (car i) '*)
232                  (equal (array-element-type object)(best-array-element-type (car i))))
233              (or (endp (cdr i)) (eq (cadr i) '*)
234                  (if (listp (cadr i))
235                      (match-dimensions (array-dimensions object) (cadr i))
236                    (eql (array-rank object) (cadr i))))))
237        (array
238         (and (arrayp object)
239              (or (endp i) (eq (car i) '*)
240                  ;; Or the element type of object should be EQUAL to (car i).
241                  ;; Is this too strict?
242                  (equal (array-element-type object) (best-array-element-type (car i))))
243              (or (endp (cdr i)) (eq (cadr i) '*)
244                  (if (listp (cadr i))
245                      (match-dimensions (array-dimensions object) (cadr i))
246                    (eql (array-rank object) (cadr i))))))
247        (t
248         (cond ((setq tem (get tp 'si::s-data))
249                (structure-subtype-p object tem))
250               ((setq tem (get tp 'deftype-definition))
251                  (typep object
252                         (apply tem i)))))))
253    
254    
255    ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
256    ;;; The result is always a list.
257    (defun normalize-type (type &aux tp i )
258      ;; Loops until the car of type has no DEFTYPE definition.
259      (loop
260        (if (atom type)
261            (setq tp type i nil)
262            (setq tp (car type) i (cdr type)))
263        (if (get tp 'deftype-definition)
264            (setq type (apply (get tp 'deftype-definition) i))
265            (return-from normalize-type (if (atom type) (list type) type)))))
266    
267    
268    ;;; KNOWN-TYPE-P answers if the given type is a known base type.
269    ;;; The type may not be normalized.
270    (defun known-type-p (type)
271      (when (consp type) (setq type (car type)))
272      (if (or (equal (string type) "ERROR")
273              (member type
274                      '(t nil boolean null symbol keyword atom cons list sequence
275                          signed-char unsigned-char signed-short unsigned-short
276                          number integer bignum rational ratio float method-combination
277                          short-float single-float double-float long-float complex
278                          character standard-char string-char real
279                          package stream pathname readtable hash-table random-state
280                          structure array simple-array function compiled-function
281                          arithmetic-error base-char base-string broadcast-stream
282                          built-in-class cell-error class concatenated-stream condition
283                          control-error division-by-zero echo-stream end-of-file error
284                          extended-char file-error file-stream floating-point-inexact
285                          floating-point-invalid-operation floating-point-overflow
286                          floating-point-underflow generic-function logical-pathname method
287                          package-error parse-error print-not-readable program-error
288                          reader-error serious-condition simple-base-string simple-condition
289                          simple-type-error simple-warning standard-class
290                          standard-generic-function standard-method standard-object
291                          storage-condition stream-error string-stream structure-class
292                          style-warning synonym-stream two-way-stream structure-object
293                          type-error unbound-slot unbound-variable undefined-function
294                          warning ))
295              (get type 's-data))
296          t
297          nil))
298    
299    
300    ;;; SUBTYPEP predicate.
301    (defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem)
302      (declare (ignore env))
303      (let ((c1 (classp type1)) (c2 (classp type2)))
304        (when (and c1 c2)
305          (return-from subtypep
306                       (if (member type2 (class-precedence-list type1))
307                           (values t t) (values nil t))))
308        (when (and c1 (or (eq type2 'structure-object) (eq type2 'standard-object)))
309          (return-from subtypep
310                       (if (member (find-class type2) (class-precedence-list type1))
311                           (values t t) (values nil t))))
312        (when (or c1 c2)
313          (return-from subtypep (values nil t))))
314      (setq t1 (normalize-type type1))
315      (setq type1 (if (eq (car t1) 'satisfies) (list type1) t1))
316      (setq t2 (normalize-type type2))
317      (setq type2 (if (eq (car t2) 'satisfies) (list type2) t2))
318    ;  (setq type1 (normalize-type type1))
319    ;  (setq type2 (normalize-type type2))  
320      (when (equal type1 type2)
321        (return-from subtypep (values t t)))
322      (setq t1 (car type1) t2 (car type2))
323      (setq i1 (cdr type1) i2 (cdr type2))
324      (cond ((eq t1 'member)
325             (dolist (e i1)
326               (unless (typep e type2) (return-from subtypep (values nil t))))
327             (return-from subtypep (values t t)))
328            ((eq t1 'or)
329             (dolist (tt i1)
330               (multiple-value-bind (tv flag) (subtypep tt type2)
331                 (unless tv (return-from subtypep (values tv flag)))))
332             (return-from subtypep (values t t)))
333            ((eq t1 'and)
334             (dolist (tt i1)
335               (let ((tv (subtypep tt type2)))
336                 (when tv (return-from subtypep (values t t)))))
337             (return-from subtypep (values nil nil)))
338            ((eq t1 'not)
339             ;;
340             (return-from subtypep
341                          (if (eq t2 'not)
342                              (subtypep (car i2) (car i1))
343                            (subtypep t `(or ,type2 ,(car i1)))))))
344      (cond ((eq t2 'member)
345             (return-from subtypep (values nil nil)))
346            ((eq t2 'or)
347             (dolist (tt i2)
348               (let ((tv (subtypep type1 tt)))
349                 (when tv (return-from subtypep (values t t)))))
350             (return-from subtypep (values nil nil)))
351            ((eq t2 'and)
352             (dolist (tt i2)
353               (multiple-value-bind (tv flag) (subtypep type1 tt)
354                 (unless tv (return-from subtypep (values tv flag)))))
355             (return-from subtypep (values t t)))
356            ((eq t2 'not)
357             (return-from subtypep (subtypep `(and ,type1 ,(car i2)) nil))))
358            
359      (setq ntp1 (known-type-p type1) ntp2 (known-type-p type2))
360      (cond ((or (eq t1 'nil) (eq t2 't) (eq t2 'common)) (values t t))
361            ((eq t2 'nil) (values nil ntp1))
362            ((eq t1 't) (values nil ntp2))
363            ((eq t1 'common) (values nil ntp2))
364            ((eq t2 'list)
365             (cond ((member t1 '(null cons)) (values t t))
366                   (t (values nil ntp1))))
367            ((eq t2 'sequence)
368             (cond ((member t1 '(null cons list))
369                    (values t t))
370                   ((or (eq t1 'simple-array) (eq t1 'array))
371                    (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
372                        (values t t)
373                        (values nil t)))
374                   (t (values nil ntp1))))
375            ((eq t1 'list) (values nil ntp2))
376            ((eq t1 'sequence) (values nil ntp2))
377            ((eq t2 'atom)
378             (cond ((member t1 '(cons list)) (values nil t))
379                   (ntp1 (values t t))
380                   (t (values nil nil))))
381            ((eq t1 'atom) (values nil ntp2))
382            ((eq t2 'symbol)
383             (if (member t1 '(keyword boolean null))
384                 (values t t)
385                 (values nil ntp1)))
386            ((eq t2 'function)
387             (if (member t1 '(compiled-function generic-function standard-generic-function))
388                 (values t t)
389                 (values nil ntp1)))
390            ((eq t2 'generic-function)
391             (if (eq t1 'standard-generic-function)
392                 (values t t)
393                 (values nil ntp1)))
394            ((eq t2 'boolean)
395             (if (eq t1 'null)
396                 (values t t)
397                 (values nil ntp1)))
398            ((eq t2 'standard-object)
399             (if (member t1 '(class built-in-class structure-class standard-class
400                                    method standard-method))
401                 (values t t)
402                 (values nil ntp1)))
403            ((eq t2 'class)
404             (if (member t1 '(built-in-class structure-class standard-class ))
405                 (values t t)
406                 (values nil ntp1)))
407            ((eq t2 'condition)
408             (if (or (equal (string t1) "ERROR")
409                     (member t1 '(serious-condition error type-error simple-type-error
410                                                parse-error cell-error unbound-slot
411                                                warning style-warning storage-condition
412                                                simple-warning unbound-variable control-error
413                                                program-error undefined-function
414                                                package-error arithmetic-error
415                                                division-by-zero simple-condition
416                                                floating-point-invalid-operation
417                                                floating-point-inexact
418                                                floating-point-overflow
419                                                floating-point-underflow
420                                                file-error stream-error end-of-file
421                                                print-not-readable
422                                                reader-error)))
423                 (values t t)
424                 (values nil ntp1)))
425            ((eq t2 'serious-condition)
426             (if (or (equal (string t1) "ERROR")
427                     (member t1 '( error type-error simple-type-error
428                                         parse-error cell-error unbound-slot
429                                         storage-condition
430                                         unbound-variable control-error
431                                         program-error undefined-function
432                                         package-error arithmetic-error
433                                         division-by-zero simple-type-error
434                                         floating-point-invalid-operation
435                                         floating-point-inexact
436                                         floating-point-overflow
437                                         floating-point-underflow
438                                         file-error stream-error end-of-file
439                                         print-not-readable
440                                         reader-error)))
441                 (values t t)
442                 (values nil ntp1)))
443            ((eq t2 'type-error)
444             (if (eq t1 'simple-type-error)
445                 (values t t)
446                 (values nil ntp1)))
447            ((eq t2 'parse-error)
448             (if (eq t1 'reader-error)
449                 (values t t)
450                 (values nil ntp1)))
451            ((eq t2 'stream-error)
452             (if (member t1 '(reader-error end-of-file))
453                 (values t t)
454                 (values nil ntp1)))
455            ((or (equal (string t2) "ERROR") (eq t2 'error))
456             (if (member t1 '(simple-type-error type-error
457                              parse-error cell-error unbound-slot
458                              unbound-variable control-error
459                              program-error undefined-function
460                              package-error arithmetic-error
461                              division-by-zero simple-type-error
462                              floating-point-invalid-operation
463                              floating-point-inexact
464                              floating-point-overflow
465                              floating-point-underflow
466                              file-error stream-error end-of-file print-not-readable
467                              reader-error ))
468                 (values t t)
469                 (values nil ntp1)))
470            ((eq t2 'stream)
471             (if (member t1 '(broadcast-stream concatenated-stream echo-stream file-stream
472                                               string-stream synonym-stream two-way-stream))
473                 (values t t)
474                 (values nil ntp1)))
475            ((eq t2 'pathname)
476             (if (eq t1 'logical-pathname)
477                 (values t t)
478                 (values nil ntp1)))
479            ((eq t2 'method)
480             (if (eq t1 'standard-method)
481                 (values t t)
482                 (values nil ntp1)))
483            ((eq t2 'simple-condition)
484             (if (member t1 '(simple-type-error simple-warning))
485                 (values t t)
486                 (values nil ntp1)))
487            ((eq t2 'simple-condition)
488             (if (member t1 '(simple-type-error simple-warning))
489                 (values t t)
490                 (values nil ntp1)))
491            ((eq t2 'cell-error)
492             (if (member t1 '(unbound-slot unbound-variable undefined-function))
493                 (values t t)
494                 (values nil ntp1)))
495            ((eq t2 'warning)
496             (if (member t1 '(style-warning simple-warning))
497                 (values t t)
498                 (values nil ntp1)))
499            ((eq t2 'arithmetic-error)
500             (if (member t1 '(division-by-zero
501                              floating-point-invalid-operation
502                              floating-point-inexact
503                              floating-point-overflow
504                              floating-point-underflow ))
505                 (values t t)
506                 (values nil ntp1)))
507            ((eq t2 'keyword)
508             (if (eq t1 'keyword) (values t t) (values nil ntp1)))
509            ((eq t2 'null)
510             (if (eq t1 'null) (values t t) (values nil ntp1)))
511            ((eq t2 'number)
512             (cond ((member t1 '(bignum integer ratio rational float real
513                                 short-float single-float double-float long-float
514                                 complex number))
515                    (values t t))
516                   (t (values nil ntp1))))
517            ((eq t1 'number) (values nil ntp2))
518            ((or (eq t2 'structure) (eq t2 'structure-object))
519             (if (or (eq t1 'structure) (get t1 'si::s-data))
520                 (values t t)
521                 (values nil ntp1)))
522            ((eq t1 'structure) (values nil ntp2))
523            ((setq tem (get t1 'si::s-data))
524             (let ((tem2 (get t2 'si::s-data)))
525               (cond (tem2
526                       (do ((tp1 tem (s-data-includes tp1)) (tp2 tem2))
527                           ((null tp1)(values nil t))
528                           (when (eq tp1 tp2) (return (values t t)))))
529                     (t (values nil ntp2)))))
530            ((eq t2 'real)
531             (cond ((and
532                     (member t1 '(fixnum integer bignum float short-float
533                                         single-float double-float long-float
534                                         real ratio
535                                         rational))
536                     (sub-interval-p i1 i2))
537                    (values t t))
538                   (t (values nil ntp1))))
539            ((get t2 'si::s-data) (values nil ntp1))
540            (t
541             (case t1
542               (bignum
543                (case t2
544                  (bignum (values t t))
545                  ((integer rational)
546                   (if (sub-interval-p '(* *) i2)
547                       (values t t)
548                       (values nil t)))
549                  (t (values nil ntp2))))
550               (ratio
551                (case t2
552                  (rational
553                   (if (sub-interval-p '(* *) i2) (values t t) (values nil t)))
554                  (t (values nil ntp2))))
555               (standard-char
556                (if (member t2 '(base-char string-char character))
557                    (values t t)
558                    (values nil ntp2)))
559               (base-char
560                (if (member t2 '(character string-char))
561                    (values t t)
562                    (values nil ntp2)))
563               (extended-char
564                (if (member t2 '(character string-char))
565                    (values t t)
566                    (values nil ntp2)))
567               (string-char
568                (if (eq t2 'character)
569                    (values t t)
570                    (values nil ntp2)))
571               (character
572                (if (eq t2 'string-char)
573                    (values t t)
574                    (values nil ntp2)))
575               (integer
576                (if (member t2 '(integer rational))
577                    (values (sub-interval-p i1 i2) t)
578                    (values nil ntp2)))
579               (rational
580                (if (eq t2 'rational)
581                    (values (sub-interval-p i1 i2) t)
582                    (values nil ntp2)))
583               (float
584                (if (eq t2 'float)
585                    (values (sub-interval-p i1 i2) t)
586                    (values nil ntp2)))
587               ((short-float)
588                (if (member t2 '(short-float float))
589                    (values (sub-interval-p i1 i2) t)
590                    (values nil ntp2)))
591               ((single-float double-float long-float)
592                (if (member t2 '(single-float double-float long-float float))
593                    (values (sub-interval-p i1 i2) t)
594                    (values nil ntp2)))
595               (complex
596                (if (eq t2 'complex)
597                    (subtypep (or (car i1) t) (or (car i2) t))
598                    (values nil ntp2)))
599               (simple-array
600                (cond ((or (eq t2 'simple-array) (eq t2 'array))
601                       (if (or (endp i1) (eq (car i1) '*))
602                           (unless (or (endp i2) (eq (car i2) '*))
603                                   (return-from subtypep (values nil t)))
604                           (unless (or (endp i2) (eq (car i2) '*))
605                                   (unless (or (equal (car i1) (car i2))
606                                               ; FIXME
607                                               (and (eq (car i1) 'base-char)
608                                                    (eq (car i2) 'string-char)))
609                                           ;; Unless the element type matches,
610                                           ;;  return NIL T.
611                                           ;; Is this too strict?
612                                           (return-from subtypep
613                                                        (values nil t)))))
614                       (when (or (endp (cdr i1)) (eq (cadr i1) '*))
615                             (if (or (endp (cdr i2)) (eq (cadr i2) '*))
616                                 (return-from subtypep (values t t))
617                                 (return-from subtypep (values nil t))))
618                       (when (or (endp (cdr i2)) (eq (cadr i2) '*))
619                             (return-from subtypep (values t t)))
620                       (values (match-dimensions (cadr i1) (cadr i2)) t))
621                      (t (values nil ntp2))))
622               (array
623                (cond ((eq t2 'array)
624                       (if (or (endp i1) (eq (car i1) '*))
625                           (unless (or (endp i2) (eq (car i2) '*))
626                                   (return-from subtypep (values nil t)))
627                           (unless (or (endp i2) (eq (car i2) '*))
628                                   (unless (or (equal (car i1) (car i2))
629                                               ; FIXME
630                                               (and (eq (car i1) 'base-char)
631                                                    (eq (car i2) 'string-char)))
632                                           (return-from subtypep
633                                                        (values nil t)))))
634                       (when (or (endp (cdr i1)) (eq (cadr i1) '*))
635                             (if (or (endp (cdr i2)) (eq (cadr i2) '*))
636                                 (return-from subtypep (values t t))
637                                 (return-from subtypep (values nil t))))
638                       (when (or (endp (cdr i2)) (eq (cadr i2) '*))
639                             (return-from subtypep (values t t)))
640                       (values (match-dimensions (cadr i1) (cadr i2)) t))
641                      (t (values nil ntp2))))
642               (t (if ntp1 (values (eq t1 t2) t) (values nil nil)))))))
643    
644    
645    (defun sub-interval-p (i1 i2)
646      (let (low1 high1 low2 high2)
647        (if (endp i1)
648            (setq low1 '* high1 '*)
649            (if (endp (cdr i1))
650                (setq low1 (car i1) high1 '*)
651                (setq low1 (car i1) high1 (cadr i1))))
652        (if (endp i2)
653            (setq low2 '* high2 '*)
654            (if (endp (cdr i2))
655                (setq low2 (car i2) high2 '*)
656                (setq low2 (car i2) high2 (cadr i2))))
657        (cond ((eq low1 '*)
658               (unless (eq low2 '*)
659                       (return-from sub-interval-p nil)))
660              ((eq low2 '*))
661              ((consp low1)
662               (if (consp low2)
663                   (when (< (car low1) (car low2))
664                         (return-from sub-interval-p nil))
665                   (when (< (car low1) low2)
666                         (return-from sub-interval-p nil))))
667              ((if (consp low2)
668                   (when (<= low1 (car low2))
669                         (return-from sub-interval-p nil))
670                   (when (< low1 low2)
671                         (return-from sub-interval-p nil)))))
672        (cond ((eq high1 '*)
673               (unless (eq high2 '*)
674                       (return-from sub-interval-p nil)))
675              ((eq high2 '*))
676              ((consp high1)
677               (if (consp high2)
678                   (when (> (car high1) (car high2))
679                         (return-from sub-interval-p nil))
680                   (when (> (car high1) high2)
681                         (return-from sub-interval-p nil))))
682              ((if (consp high2)
683                   (when (>= high1 (car high2))
684                         (return-from sub-interval-p nil))
685                   (when (> high1 high2)
686                         (return-from sub-interval-p nil)))))
687        (return-from sub-interval-p t)))
688    
689    (defun in-interval-p (x interval)
690      (let (low high)
691        (if (endp interval)
692            (setq low '* high '*)
693            (if (endp (cdr interval))
694                (setq low (car interval) high '*)
695                (setq low (car interval) high (cadr interval))))
696        (cond ((eq low '*))
697              ((consp low)
698               (when (<= x (car low)) (return-from in-interval-p nil)))
699              ((when (< x low) (return-from in-interval-p nil))))
700        (cond ((eq high '*))
701              ((consp high)
702               (when (>= x (car high)) (return-from in-interval-p nil)))
703              ((when (> x high) (return-from in-interval-p nil))))
704        (return-from in-interval-p t)))
705    
706    (defun match-dimensions (dim pat)
707      (if (null dim)
708          (null pat)
709          (and (or (eq (car pat) '*)
710                   (eql (car dim) (car pat)))
711               (match-dimensions (cdr dim) (cdr pat)))))
712    
713    
714    
715    ;;; COERCE function.
716    (defun coerce (object type)
717      (when (typep object type)
718            ;; Just return as it is.
719            (return-from coerce object))
720      (when (classp type)
721        (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S~%" object type))
722      (setq type (normalize-type type))
723      (case (car type)
724        (list
725         (do ((l nil (cons (elt object i) l))
726              (i (1- (length object)) (1- i)))
727             ((< i 0) l)))
728        ((array simple-array)
729         (unless (or (endp (cdr type))
730                     (endp (cddr type))
731                     (eq (caddr type) '*)
732                     (endp (cdr (caddr type))))
733                 (error "Cannot coerce to an multi-dimensional array."))
734         (do ((seq (make-sequence type (length object)))
735              (i 0 (1+ i))
736              (l (length object)))
737             ((>= i l) seq)
738           (setf (elt seq i) (elt object i))))
739        (character (character object))
740        (float (float object))
741        ((short-float) (float object 0.0S0))
742        ((single-float double-float long-float) (float object 0.0L0))
743        (complex
744         (if (or (null (cdr type)) (null (cadr type)) (eq (cadr type) '*))
745             (complex (realpart object) (imagpart object))
746             (complex (coerce (realpart object) (cadr type))
747                      (coerce (imagpart object) (cadr type)))))
748        (t (error "Cannot coerce ~S to ~S." object type))))
749    
750    ;; set by unixport/init_kcl.lsp
751    ;; warn if a file was comopiled in another version
752    (defvar *gcl-version* nil)
753    (defvar *gcl-major-version* nil)
754    
755    (defun warn-version (x &optional majvers)
756      (and *gcl-version*
757           (or (not (eql x *gcl-version*))
758               (not (eql majvers *gcl-major-version*)))
759           *load-verbose*
760           (format t "[compiled in GCL ~a-~a] " majvers x)))
761    
762    
763    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

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