source: project/release/3/procedure-surface/trunk/signature-type.scm @ 9957

Last change on this file since 9957 was 9957, checked in by Kon Lovett, 11 years ago

Rel 1.1.1 w/ defered use of SRFI 69.

File size: 22.6 KB
Line 
1;;;; signature-type.scm
2;;;; Kon Lovett, May '06
3
4(eval-when (compile)
5  (declare
6    (usual-integrations)
7    (fixnum)
8    (lambda-lift)
9    (inline)
10    (no-procedure-checks)
11    (no-bound-checks)
12    (bound-to-procedure
13      make-signature-type)
14    (export
15      build-signature-type-builtins
16      make-signature-type
17      signature-type?
18      signature-extended-type?
19      signature-leaf-type?
20      signature-type-a-kind-of?
21      signature-type-ref
22      signature-type-name
23      signature-type-predicate
24      signature-type-specializer
25      signature-type-extends
26      signature-type-extension
27      signature-type-delete!
28      signature-type-replace!
29      make-signature-contract) ) )
30
31(use srfi-1 srfi-26 extras utils)
32(use lookup-table misc-extn-record misc-extn-control misc-extn-symbol)
33
34;;;
35
36;;
37
38(define-inline-unchecked-record-type signature-type
39  (%make-signature-type name predicate specializer extends extension)
40  %signature-type?
41  (name %signature-type-name)
42  (predicate %signature-type-predicate)
43  (specializer %signature-type-specializer %signature-type-specializer-set!)
44  (extends %signature-type-extends %signature-type-extends-set!)
45  (extension %signature-type-extension %signature-type-extension-set!) )
46
47;;
48
49(define-record-printer (signature-type obj out)
50  (fprintf out "#<signature-type ~S ~S ~S ~S ~S>"
51    (%signature-type-name obj)
52    (%signature-type-predicate obj)
53    (%signature-type-specializer obj)
54    (list '...)
55    (%signature-type-extension obj)) )
56
57;;
58
59(define *datum* #f)
60(define *object* #f)
61(define *signature-types* #f)
62
63;;
64
65(define-inline (%signature-type-ref obj)
66  (let ([typ (or (and (symbol? obj) (dict-ref *signature-types* obj)) obj)])
67    (and (%signature-type? typ) typ)) )
68
69;;
70
71(define-inline (%signature-leaf-type? typ)
72  (null? (%signature-type-extension typ)) )
73
74;;
75
76(define-inline (%signature-extended-type? typ)
77  (not (%signature-leaf-type? typ)) )
78
79;; Used to stop make-signature-type from attempting to immediately
80;; access the binding.
81;;
82
83(define-macro (defer-predicate PRED . ARGS)
84  (let ([VAR (gensym)])
85    `(lambda (,VAR) (,PRED ,VAR ,@ARGS)) ) )
86
87;;
88
89(define (build-signature-type-builtins)
90
91  (define void?
92    (cut eq? <> (void)) )
93
94  (define (datum? obj)
95    #t )
96
97  (define (structure? x)
98    ;;FIXME
99    (##sys#generic-structure? x) )
100
101  (define (environment? x)
102    (##sys#structure? x 'environment) )
103
104  (define (read-table? x)
105    (##sys#structure? x 'read-table) )
106
107  (define (datum-specializer this . args)
108    (if (pair? args)
109      (let ([that (car args)])
110        (apply (%signature-type-specializer that) that (cdr args)))
111      (error "missing specialization" 'datum)) )
112
113  ; Types table
114  (set! *signature-types* (make-dict 47))
115
116  ; Datum is itself
117  (set! *datum* (%make-signature-type 'datum datum? datum-specializer '() '()))
118  (%signature-type-extends-set! *datum* `(,*datum*))
119  (%signature-type-set! 'datum *datum*)
120
121  ; Chicken toplevel type
122  (set! *object* (make-signature-type 'object *datum*))
123
124  ;; Builtin primitives
125
126  (make-signature-type 'void 'object void?)
127
128  ; Chicken internal tagged block (is this useful?)
129  (make-signature-type 'structure 'object structure?)
130
131  (make-signature-type 'boolean 'object)
132
133  (make-signature-type 'symbol 'object)
134  (make-signature-type 'keyword 'symbol)
135
136  (make-signature-type 'char 'object)
137
138  (make-signature-type 'string 'object)
139
140  (make-signature-type 'vector 'object)
141
142  (make-signature-type 'list 'object)
143  (make-signature-type 'pair 'list)
144  (make-signature-type 'null 'list)
145
146  (make-signature-type 'port 'object)
147  (make-signature-type 'input-port 'port)
148  (make-signature-type 'output-port 'port)
149
150  (make-signature-type 'eof 'object eof-object?)
151
152  (make-signature-type 'procedure 'object)
153
154  ; Chicken lolevel or syntax-case macro?
155  (make-signature-type 'macro 'procedure)
156
157  (make-signature-type 'continuation 'object)
158
159  (make-signature-type 'promise 'object)
160
161  (make-signature-type 'environment 'object environment?)
162
163  (make-signature-type 'read-table 'object read-table?)
164
165  ; Chicken builtin or numbers egg ? Treat as an extension.
166  (make-signature-type 'number 'object (defer-predicate number?))
167  (make-signature-type 'exact 'number (defer-predicate exact?))
168  (make-signature-type 'inexact 'number (defer-predicate inexact?))
169  (make-signature-type 'real 'number (defer-predicate real?))
170  (make-signature-type 'integer 'real (defer-predicate integer?))
171  (make-signature-type 'fixnum '(exact integer) fixnum?)
172  (make-signature-type 'flonum '(inexact real) flonum?)
173  (make-signature-type 'rational 'real (defer-predicate rational?))
174  (make-signature-type 'complex 'number (defer-predicate complex?))
175
176  ;; The extension or library containing the type predicates better be
177  ;; loaded before the predicate is used! The defer-predicate will
178  ;; delay access to the binding until time of use.
179
180  ;; Builtin extensions (Chicken library units)
181
182  ; Chicken queue
183  (make-signature-type 'queue 'object (defer-predicate queue?))
184
185  ; SRFI 4
186  (make-signature-type 'u8vector 'object (defer-predicate u8vector?))
187  (make-signature-type 's8vector 'object (defer-predicate s8vector?))
188  (make-signature-type 'u16vector 'object (defer-predicate u16vector?))
189  (make-signature-type 's16vector 'object (defer-predicate s16vector?))
190  (make-signature-type 'u32vector 'object (defer-predicate u32vector?))
191  (make-signature-type 's32vector 'object (defer-predicate s32vector?))
192  (make-signature-type 'f32vector 'object (defer-predicate f32vector?))
193  (make-signature-type 'f64vector 'object (defer-predicate f64vector?))
194
195  ; SRFI 12
196  (make-signature-type 'condition 'object (defer-predicate condition?))
197
198  ; SRFI 14
199  (make-signature-type 'char-set 'object (defer-predicate char-set?))
200
201  ; Posix
202  (make-signature-type 'mmap 'object (defer-predicate memory-mapped-file?))
203  (make-signature-type 'terminal-port 'port (defer-predicate terminal-port?))
204
205  ; TCP
206  (make-signature-type 'tcp-listener 'object (defer-predicate tcp-listener?))
207
208  ; SRFI 18
209  (make-signature-type 'thread 'object (defer-predicate thread?))
210  (make-signature-type 'lock 'object (defer-predicate lock?))
211  (make-signature-type 'mutex 'object (defer-predicate mutex?))
212  (make-signature-type 'condition-variable 'object (defer-predicate condition-variable?))
213
214  ; SRFI 18 (SRFI 19)
215  (make-signature-type 'time 'object (defer-predicate time?))
216
217  ; Regexp
218  (make-signature-type 'regexp 'object (defer-predicate regexp?))
219
220  ; Lolevel
221  (make-signature-type 'pointer 'object (defer-predicate pointer?))
222  (make-signature-type 'tagged-pointer 'pointer (defer-predicate tagged-pointer?))
223  (make-signature-type 'swig-pointer 'pointer (defer-predicate swig-pointer?))
224  (make-signature-type 'locative 'object (defer-predicate locative?))
225  (make-signature-type 'byte-vector 'object (defer-predicate byte-vector?))
226  (make-signature-type 'extended-procedure 'procedure (defer-predicate extended-procedure?))
227  (make-signature-type 'object-evicted 'object (defer-predicate object-evicted?))
228  (make-signature-type 'record 'structure (defer-predicate record-instance?))
229
230  ; SRFI 69
231  (make-signature-type 'hash-table 'object (defer-predicate hash-table?))
232
233  ;; Sample extensions
234
235  ; TinyCLOS
236  (make-signature-type 'clos-object 'object (defer-predicate instance?))
237  (make-signature-type 'class 'clos-object (defer-predicate instance-of? <class>))
238  (make-signature-type 'method 'clos-object (defer-predicate instance-of? <method>))
239  (make-signature-type 'generic 'clos-object (defer-predicate instance-of? <generic>))
240  (make-signature-type 'c++-object 'clos-object (defer-predicate instance-of? <c++-object>))
241
242  ; SRFI 19
243  (make-signature-type 'date 'object (defer-predicate date?))
244
245  ; SRFI 25, SRFI 47, SRFI 63
246  (make-signature-type 'array 'object (defer-predicate array?))
247
248  ; Futures egg
249  (make-signature-type 'future 'object (defer-predicate future?)) )
250
251;; Add this type as an extension of the extended types
252;;
253
254(define (extend-type typ)
255  (for-each
256    (lambda (etyp)
257      (let ([extn (%signature-type-extension etyp)])
258        (unless (memq typ extn)
259          (%signature-type-extension-set! etyp (cons typ extn)))))
260    (%signature-type-extends typ)) )
261
262;; Add this type as an extended type
263;;
264
265(define (reextend-type typ)
266  (for-each
267    (lambda (etyp)
268      (let ([extd (%signature-type-extends etyp)])
269        (unless (memq typ extd)
270          (%signature-type-extends-set! etyp (cons typ extd)))))
271    (%signature-type-extension typ)) )
272
273;; Remove this type as an extension of the extended types
274;;
275
276(define (contract-type typ)
277  (for-each
278    (lambda (etyp)
279      (%signature-type-extension-set! etyp
280        (remove! (cut eq? <> typ) (%signature-type-extension etyp))))
281    (%signature-type-extends typ)) )
282
283;; Remove this type as an extended type
284;;
285
286(define (unextend-type typ)
287  (for-each
288    (lambda (etyp)
289      (%signature-type-extends-set! etyp
290        (remove! (cut eq? <> typ) (%signature-type-extends etyp))))
291    (%signature-type-extension typ)) )
292
293;; Is 'that', ultimately, an extension of type?
294;;
295
296(define (a-kind-of? that type #!optional (roots `(,*datum* ,*object*)))
297  (cond
298    ; Don't include roots
299    [(memq type roots)
300      #f]
301    [else
302      (let ([extn (%signature-type-extension type)])
303        ; Immediately part of the extension?
304        ; Else backup the hierarchy
305        (or (memq that extn)
306            (any (cut a-kind-of? that <>) extn)))]) )
307
308;; A type that, ultimately, extends itself?
309;;
310
311(define-inline (signature-type-loop? typ)
312  (a-kind-of? typ typ) )
313
314;;
315
316(define (%checked-signature-type-ref obj loc msg)
317  (let ([typ (%signature-type-ref obj)])
318    (unless typ
319      (error loc msg obj))
320    typ) )
321
322;; Clean addition of type
323;;
324
325(define (%signature-type-set! nam typ)
326
327  ; Successfully add to table before extending type
328  (dict-set! *signature-types* nam typ)
329
330  ; Make back pointers from the extended
331  (extend-type typ)
332
333  ; Handle default specializer
334  (unless (%signature-type-specializer typ)
335    (%signature-type-specializer-set! typ
336      (if (%signature-leaf-type? typ)
337          ;then assume no specialization
338        (lambda (this . args)
339          (error "cannot specialize" nam))
340          ;else assume parent can specialize
341        (lambda (this . args)
342          (if (pair? args)
343            (let ([that (car args)])
344              (if (a-kind-of? that this)
345                (apply (%signature-type-specializer that) that (cdr args))
346                (errorf "cannot specialize '~S' from '~S'" nam (%signature-type-name that))))
347            (error "missing specialization" nam))))))
348
349  ; Finished
350  typ )
351
352;; Clean removal of type
353;;
354
355(define (%signature-type-delete! nam typ)
356
357  ; Don't extend from any type
358  (contract-type typ)
359
360  ; Don't provide extension for any type
361  (unextend-type typ)
362
363  ; Drop the type
364  (dict-delete! *signature-types* nam) )
365
366;;
367
368(define (check-make-signature-type name extends predicate specializer loc)
369
370  ; Name must be symbol
371  (unless (and name (symbol? name))
372    (error loc "type name must be a symbol" name))
373
374  ; Must extend from existing type(s)
375  (if extends
376    (begin
377      (unless (pair? extends)
378        (set! extends (list extends)))
379      (set! extends
380        (map
381          (lambda (x)
382            (%checked-signature-type-ref x
383              loc "can only extend existing type"))
384          extends)))
385    (set! extends (list *datum*)))
386
387  ; Predicate must be a procedure
388  (if predicate
389    (unless (procedure? predicate)
390      (error loc "predicate must be a procedure" predicate))
391    (begin
392      (set! predicate (symbol-value (string->symbol (conc name #\?))))
393      (unless (procedure? predicate)
394        (set! predicate (%signature-type-predicate (car extends))))))
395
396  ; Specializer must be a procedure
397  (when specializer
398    (unless (procedure? specializer)
399      (error loc "type specializer must be a procedure" specializer)))
400
401  ; Finished
402  (%make-signature-type name predicate specializer extends '()) )
403
404;;
405
406(define (make-signature-type name #!optional (extends #f) (predicate #f) (specializer #f))
407  (let ([typ (check-make-signature-type name extends predicate specializer 'make-signature-type)])
408    (when (dict-ref *signature-types* name)
409      (error 'make-signature-type "redefinition of type" name))
410    (%signature-type-set! name typ)) )
411
412;;
413
414(define-inline (checked-signature-type-ref obj loc)
415  (%checked-signature-type-ref obj loc "not a signature-type or type name symbol") )
416
417;;
418
419(define (signature-type? obj)
420  (%signature-type? (%signature-type-ref obj)) )
421
422;;
423
424(define (signature-extended-type? obj)
425  (let ([typ (checked-signature-type-ref obj 'signature-extended-type?)])
426    (%signature-extended-type? typ)) )
427
428;;
429
430(define (signature-leaf-type? obj)
431  (let ([typ (checked-signature-type-ref obj 'signature-leaf-type?)])
432    (%signature-leaf-type? typ)) )
433
434;;
435
436(define (signature-type-a-kind-of? that this)
437  (let ([this-type (checked-signature-type-ref this 'signature-type-a-kind-of?)])
438    (not
439      (not
440        (a-kind-of?
441          (checked-signature-type-ref that 'signature-type-a-kind-of?)
442          this-type
443          `(,*datum* ,@(or (and (eq? this-type *object*) '()) `(,*object*))) ) ) ) ) )
444
445;;
446
447(define (signature-type-ref obj)
448  (checked-signature-type-ref obj 'signature-type-ref) )
449
450;;
451
452(define (signature-type-name obj)
453  (let ([typ (checked-signature-type-ref obj 'signature-type-name)])
454    (%signature-type-name typ)) )
455
456;;
457
458(define (signature-type-predicate obj)
459  (let ([typ (checked-signature-type-ref obj 'signature-type-predicate)])
460    (%signature-type-predicate typ)) )
461
462;;
463
464(define (signature-type-specializer obj)
465  (let ([typ (checked-signature-type-ref obj 'signature-type-specializer)])
466    (%signature-type-specializer typ)) )
467
468;;
469
470(define (signature-type-extends obj)
471  (let ([typ (checked-signature-type-ref obj 'signature-type-extends)])
472    (list-copy (%signature-type-extends typ))) )
473
474;;
475
476(define (signature-type-extension obj)
477  (let ([typ (checked-signature-type-ref obj 'signature-type-extension)])
478    (list-copy (%signature-type-extension typ))) )
479
480;;
481
482(define (signature-type-delete! obj)
483  (let* ([typ (checked-signature-type-ref obj 'signature-type-delete!)]
484         [nam (%signature-type-name typ)])
485    (when (%signature-extended-type? typ)
486      (warning "deleting extended type" typ))
487    (%signature-type-delete! nam typ)) )
488
489;;
490
491(define (signature-type-replace! obj #!optional (name #f) (extends #f) (predicate #f) (specializer #f))
492  (let* ([typ (checked-signature-type-ref obj 'signature-type-replace!)]
493         [nam (%signature-type-name typ)])
494
495    ; Extending from the type replacing is a no-no
496    (when (and extends
497            (any
498              (lambda (etyp)
499                (a-kind-of? typ
500                  (checked-signature-type-ref etyp 'signature-type-replace!)))
501              extends))
502      (error 'signature-type-replace! "cannot extend a replaced type" nam name))
503
504    ; Missing name is the same as replaced type
505    (let ([name (or name nam)])
506      (let (
507
508          ; Save the replaced types extensions so the new type can take over the
509          ; replaced 'role'
510          [extn (%signature-type-extension typ)]
511
512          ; Provisional replacement type
513          [ntyp
514            (check-make-signature-type name extends predicate specializer
515              'signature-type-replace!)])
516
517        ; Can't define type in terms of itself
518        (%signature-type-extension-set! ntyp extn)
519        (when (signature-type-loop? ntyp)
520          (error 'signature-type-replace! "type loop" name))
521
522        ; Only after successful type loop check
523        (%signature-type-delete! nam typ)
524
525        ; Now say old extended now are from the replacement type
526        (reextend-type ntyp)
527
528        ; Finished
529        (%signature-type-set! name ntyp) ) ) ) )
530
531;; Validates syntax & returns internal contract form.
532;;
533;; No assertions - invariant, precondition, postcondition.
534;;
535
536(define (make-signature-contract contract)
537
538  ;;FIXME construct internal form
539
540  ;
541  #;(define (type-ref sym)
542    (let ([typ (%signature-type-ref sym)])
543      (unless typ
544        (error "unknown signature type" sym))
545      typ) )
546
547  ;
548  #;(define (compile-specializer-body lst)
549    (map
550      (lambda (itm)
551        (cond
552          [(symbol? itm)
553            (or (%signature-type-ref itm) itm)]
554          [(pair? itm)
555            (if (eq? 'quote (car itm))
556              (car itm)
557              (compile-specializer-body itm))]
558          [else
559            itm]))
560      lst) )
561
562  ; domain: <type> ... <DSSSL>
563  ; DSSSL: [#!optional <type> ...] [#!rest list | (list <type> ...)] [#!key (<keyword> <type>) ...]
564  ; returns alist w/ keys required, optional, rest, & key
565  (define (parse-domain rembdy)
566    (let ([more rembdy]
567          [dom '()])
568
569      ; #!required
570      (set! more
571        (let loop ([rqrds more] [lst '()])
572          (if (null? rqrds)
573            (begin
574              (set! dom (alist-cons 'required (reverse! lst) dom))
575              '())
576            (let ([rqrd (car rqrds)])
577              (if (or (eq? rqrd '#!optional) (eq? rqrd '#!key) (eq? rqrd '#!rest))
578                (begin
579                  (set! dom (alist-cons 'required (reverse! lst) dom))
580                  rqrds)
581                (loop (cdr rqrds) (cons (parse-type rqrd) lst)))))))
582
583      ; #!optional
584      (set! more
585        (if (and (pair? more) (eq? '#!optional (car more)))
586          (let loop ([opts (cdr more)] [lst '()])
587            (if (null? opts)
588              (begin
589                (set! dom (alist-cons 'optional (reverse! lst) dom))
590                '())
591              (let ([opt (car opts)])
592                (if (or (eq? opt '#!rest) (eq? opt '#!key))
593                  (begin
594                    (set! dom (alist-cons 'optional (reverse! lst) dom))
595                    opts)
596                  (loop (cdr opts) (cons (parse-type opt) lst))))))
597          more))
598
599      ; #!rest
600      (set! more
601        (if (and (pair? more) (eq? '#!rest (car more)))
602          (let ([rest (cdr more)])
603            (unless (pair? rest)
604              (error "invalid as domain #!rest" rest))
605            (let ([rst (car rest)])
606              (cond
607                [(eq? 'list rst)
608                  (set! dom (alist-cons 'rest 'list dom))
609                  (cdr rest)]
610                [(and (pair? rst) (eq? 'list (car rst)))
611                  (set! dom (alist-cons 'rest `(list ,@(map parse-type (cdr rst))) dom))
612                  (cdr rest)]
613                [else
614                  (error "invalid as domain #!rest" rest)])))
615          more))
616
617      ; #!key
618      (set! more
619        (if (and (pair? more) (eq? '#!key (car more)))
620          (let loop ([keys (cdr more)] [lst '()])
621            (if (null? keys)
622              (begin
623                (set! dom (alist-cons 'key (reverse! lst) dom))
624                '())
625              (let ([pair (car keys)])
626                (unless (pair? pair)
627                  (error "invalid as domain #!key" pair))
628                (let ([key (car pair)])
629                  (unless (keyword? key)
630                    (error "invalid as domain #!key" key))
631                  (loop (cdr keys) (cons (cons key (parse-type (cadr pair))) lst))))))
632          more))
633
634      ; Parses. Note that domain can be null.
635      (unless (null? more)
636        (error "extraneous domain item" more))
637      dom) )
638
639  ; specialization: <map> | (<type> ...) | (or <type> ...)
640  (define (parse-specialization specialization)
641    (cond
642      [(pair? specialization)
643        (let ([kind (car specialization)])
644          (cond
645            [(or (eq? '-> kind) (eq? 'procedure kind))
646              (parse-map specialization)]
647            [(eq? 'or kind)
648              `(or ,@(map parse-type (cdr specialization)))]
649            [else
650              (if (parse-type kind)
651                ; Accept anything as parameter(s) for now
652                specialization
653                (error "invalid specialization" specialization))]))]
654      [else
655        (error "invalid specialization" specialization)]) )
656
657  ; type: <symbol> | <specialization> | <map>
658  (define (parse-type type)
659    (cond
660      [(pair? type)
661        (parse-specialization type)]
662      [(symbol? type)
663        (if (eq? '|()| type)
664          'null
665          type)]
666      [else
667        (error "invalid type" type)]) )
668
669  ; throws-body: <symbol> ...
670  (define (parse-throws-body exps kind)
671    (map
672      (lambda (exp)
673        (cond
674          [(pair? exp)
675            (unless (every symbol? exp)
676              (errorf "invalid map ~S conditions ~A" kind exp))
677            exp]
678          [(symbol? exp)
679            exp]
680          [else
681            (errorf "invalid map ~S condition ~A" kind exp)]))
682      exps) )
683
684  ; values-body: <type> ...
685  (define (parse-values-body values)
686    (map parse-type values) )
687
688  ; range: <type> [<throw> ...] | (values <type> ...) [<throw> ...]
689  ; returns parsed range and unparsed domain
690  (define (parse-range rbody)
691    (if (null? rbody)
692      (error "invalid map empty range")
693      (let ([hd (car rbody)]
694            [tl (cdr rbody)])
695        (cond
696          [(pair? hd)
697            (let ([kind (car hd)])
698              (cond
699                [(or (eq? 'signals kind) (eq? 'aborts kind))
700                  (let ([exps (parse-throws-body (cdr hd) kind)])
701                    (let-values (([rng dom] (parse-range tl)))
702                      (values `(,@rng (,kind ,@exps)) dom)))]
703                [(eq? 'values kind)
704                  (values `((values ,@(parse-values-body (cdr hd)))) tl)]
705                [else
706                  (let ([rng (parse-type hd)])
707                    #;(unless rng
708                      (error "invalid map range" hd))
709                    (values `(,rng) tl))]))]
710          [else
711            (values `(,(parse-type hd)) tl)]) ) ) )
712
713  ; map-body: domain range
714  ; returns (parsed-domain parsed-range)
715  (define (parse-map-body body)
716    (if (null? body)
717      (error "invalid map null range")
718      (let-values (([rng dom] (parse-range (reverse body))))
719        `(,(parse-domain (reverse! dom)) ,rng)) ) )
720
721  ; map: (-> domain range)
722  ; returns (-> parsed-domain parsed-range)
723  (define (parse-map specialization)
724    (let ([kind (car specialization)])
725      (cond
726        [(or (eq? '-> kind) (eq? 'procedure kind))
727          `(procedure ,@(parse-map-body (cdr specialization)))]
728        [else
729          (error "invalid map" specialization)]) ) )
730
731  ; Contract should be specialization of ->
732  (if (null? contract)
733    '()
734    (let (
735        ; Allow implicit toplevel 'or'
736        [spec
737          (parse-specialization
738            (if (and (pair? contract) (pair? (car contract)))
739              `(or ,@contract)
740              contract))])
741      ; Toplevel can only be a map or disjoint set of map
742      (if (or (eq? 'procedure (car spec))
743              (and (eq? 'or (car spec))
744                (every
745                  (lambda (x)
746                    (and (pair? x) (eq? 'procedure (car x))))
747                  (cdr spec))))
748        spec
749        (error "invalid contract" contract)))) )
750
751;;;
752;;; Module Initialize
753;;;
754
755(build-signature-type-builtins)
Note: See TracBrowser for help on using the repository browser.