source: project/release/3/procedure-surface/trunk/procedure-surface-support.scm @ 9816

Last change on this file since 9816 was 9816, checked in by Kon Lovett, 12 years ago

Removed syntax-case dependency. Full low-level macro support.

File size: 21.9 KB
Line 
1;;;; procedure-surface-support.scm
2;;;; Kon Lovett, May '06
3
4;; Issues
5;;
6;; - Composite relationship DOES NOT track changes to the composited items!
7;;
8;; - A mutable procedure surface with an immutable procedure means
9;; is questionable. How to do versioning?
10;;
11;; - Procedure symbols must be interned, i.e. unique.
12;;
13;; - Performs a dict-set! during a dict-for-each. However only
14;; an existing item is modified. A new key is not added.
15;;
16;; - Loading is forced by 1st closure access.
17;;
18;; - Composite doesn't check to make sure no duplicate interface names since only
19;; the procedure symbols are relevant.
20;;
21;; - Procedural signatures are anonymous! Procedure identifier is held by the owning
22;; procedure surface.
23;;
24;; - Contracts currently are not used for anything except documentation.
25;;
26;; - Allow multiple impl procs for a sig, w/ failure criteria & automatic try?
27
28(eval-when (compile)
29  (declare
30    (usual-integrations)
31    (fixnum)
32    (lambda-lift)
33    (inline)
34    (no-procedure-checks)
35    (no-bound-checks)
36    (export
37      make-procedure-signature
38      procedure-signature?
39      procedure-signature-identifier
40      procedure-signature-contract
41      make-procedure-surface
42      procedure-surface?
43      procedure-surface-name
44      procedure-surface-immutable?
45      procedure-surface-mutable?
46      procedure-surface-ref
47      procedure-surface-set!
48      procedure-surface-delete!
49      procedure-surface->alist
50      make-composite-procedure-surface
51      composite-procedure-surface?
52      procedure-unbound?
53      make-procedure-means
54      procedure-means?
55      procedure-means-complete?
56      procedure-means-incompletes
57      procedure-means-implements
58      procedure-means-bound?
59      procedure-means-unbounds
60      procedure-means-immutable?
61      procedure-means-mutable?
62      procedure-means-alias
63      procedure-means-ref
64      procedure-means-closure
65      procedure-means-set!
66      procedure-means-delete!
67      procedure-means->alist
68      make-composite-procedure-means
69      composite-procedure-means?
70      procedure-means-load!
71      procedure-means-incomplete-closure?
72      procedure-identifier->closure) ) )
73
74(use srfi-1 srfi-2 lolevel extras utils)
75(use lookup-table misc-extn-record misc-extn-control
76     misc-extn-list misc-extn-dsssl misc-extn-symbol)
77(use signature-type)
78
79;;;
80
81;;
82
83(define-inline-unchecked-record-type procedure-signature
84  (%make-procedure-signature id contract)
85  %procedure-signature?
86  (id %procedure-signature-identifier)
87  (contract %procedure-signature-contract))
88
89;;
90
91(define-record-printer (procedure-signature obj out)
92  (fprintf out "#<procedure-signature ~S ~S>"
93    (%procedure-signature-identifier obj)
94    (%procedure-signature-contract obj)) )
95
96;;
97
98(define-inline (check-procedure-signature obj loc)
99  (unless (%procedure-signature? obj)
100    (error loc "not a procedure-signature" obj)))
101
102;;
103
104(define (make-procedure-signature id contract)
105  (%make-procedure-signature
106    id
107    #;contract
108    (make-signature-contract contract)))
109
110;;
111
112(define (procedure-signature? obj)
113  (%procedure-signature? obj))
114
115;; Returns the contract or #f when no contract or error
116
117(define (procedure-signature-identifier obj)
118  (check-procedure-signature obj 'procedure-signature-identifier)
119  (%procedure-signature-identifier obj))
120
121;; Returns the contract or #f when no contract or error
122
123(define (procedure-signature-contract obj)
124  (check-procedure-signature obj 'procedure-signature-contract)
125  (%procedure-signature-contract obj))
126
127;;;
128;;; procedure-surface
129;;;
130
131;;
132
133(define-inline-unchecked-record-type procedure-surface
134  (%make-procedure-surface name immutable signature-map)
135  %procedure-surface?
136  (name %procedure-surface-name)
137  (immutable %procedure-surface-immutable?)
138  (signature-map %procedure-surface-signature-map) )
139
140;;
141
142(define-inline (check-procedure-surface obj loc)
143  (unless (%procedure-surface? obj)
144    (error loc "not a procedure-surface" obj)) )
145
146;;
147
148(define-inline (check-procedure-surface-mutable obj loc)
149  (check-procedure-surface obj loc)
150  (when (procedure-surface-immutable? obj)
151    (error loc "immutable procedure-surface" obj)) )
152
153;;
154
155(define-inline (%procedure-surface-ref ps key)
156  (dict-ref (%procedure-surface-signature-map ps) key))
157
158;;
159
160(define-inline (%procedure-surface-set! ps lt)
161  (dict-merge! (%procedure-surface-signature-map ps) lt) )
162
163;;
164
165(define-inline (%procedure-surface-delete! ps key)
166  (dict-delete! (%procedure-surface-signature-map ps) key) )
167
168;;
169
170(define (parse-procedure-signatures pss)
171  (let loop ([pss pss] [pal '()])
172    (if (null? pss)
173        ;then finished
174        (alist->dict pal)
175        ;else parse rest
176        (let ([sym (car pss)]
177              [nxt (cdr pss)])
178          (unless (symbol? sym)
179            (error "procedure identifier must be a symbol" sym))
180          (when (null? nxt)
181            (error "missing signature" sym))
182          (loop (cdr nxt) (alist-cons sym (make-procedure-signature sym (car nxt)) pal))))))
183
184;;
185
186(define (make-procedure-surface #!rest procedure-signatures #!key (immutable #f) (name #f))
187  ;
188  (unless name
189    (set! name (gensym "ps")))
190  ;
191  (when (string? name)
192    (set! name (string->symbol name)))
193  ;
194  (unless (symbol? name)
195    (error 'make-procedure-surface
196      "name must be a symbol or string" name))
197  ;
198  (%make-procedure-surface
199    `(,name)
200    immutable
201    (parse-procedure-signatures
202      (fixup-extended-lambda-list-rest '(#:immutable #:name) procedure-signatures))))
203
204;;
205
206(define (procedure-surface? obj)
207  (%procedure-surface? obj))
208
209;;
210
211(define (procedure-surface-name obj)
212  (check-procedure-surface obj 'procedure-surface-name)
213  (let ([name (%procedure-surface-name obj)])
214    (or (and (length=1? name) (car name))
215        name)))
216
217;;
218
219(define (procedure-surface-immutable? obj)
220  (check-procedure-surface obj 'procedure-surface-immutable?)
221  (%procedure-surface-immutable? obj))
222
223;;
224
225(define (procedure-surface-mutable? obj)
226  (check-procedure-surface obj 'procedure-surface-mutable?)
227  (not (%procedure-surface-immutable? obj)))
228
229;; Returns a procedural signature or #f
230
231(define (procedure-surface-ref obj key)
232  (check-procedure-surface obj 'procedure-surface-ref)
233  (%procedure-surface-ref obj key))
234
235;; Creates or updates one or more signatures.
236
237(define (procedure-surface-set! obj #!rest pss)
238  (check-procedure-surface-mutable obj 'procedure-surface-set!)
239  (%procedure-surface-set! obj (parse-procedure-signatures pss)))
240
241;; Removes a signature. Does not complain when key has no match.
242
243(define (procedure-surface-delete! obj key)
244  (check-procedure-surface-mutable obj 'procedure-surface-delete!)
245  (%procedure-surface-delete! obj key))
246
247;;
248
249(define (procedure-surface->alist obj)
250  (check-procedure-surface obj 'procedure-surface->alist)
251  (list-copy (dict->alist (%procedure-surface-signature-map obj))))
252
253;; Combination w/o overlap (pure union)
254;; If any of the combined procedure surfaces is immutable
255;; then the composite is immutable.
256
257(define (make-composite-procedure-surface . rest)
258  ; Start with nothing
259  (let ([pal '()]
260        [names '()]
261        [immutable #f])
262    ; Accumulate the information from the procedure surfaces
263    (let loop ([ps-lst rest])
264      (unless (null? ps-lst)
265        (let ([ps (car ps-lst)])
266          ; Supposed to be a procedure-surface
267          (check-procedure-surface ps 'make-composite-procedure-surface)
268          ; Propagate immutable contagion
269          (unless immutable
270            (set! immutable (%procedure-surface-immutable? ps)))
271          ; Process every P of the PI
272          (dict-for-each
273            (%procedure-surface-signature-map ps)
274            (lambda (sym sig)
275              (when (alist-ref sym pal eq?)
276                (errorf 'make-composite-procedure-surface
277                  "procedure '~A' multiply defined" sym))
278              (set! pal (alist-cons sym sig pal))))
279          ; Collect for composite name
280          (set! names (append names (%procedure-surface-name ps)))
281        (loop (cdr ps-lst)))))
282    ; Composition done
283    (%make-procedure-surface
284      names
285      immutable
286      (alist->dict pal))))
287
288;;
289
290(define (composite-procedure-surface? obj)
291  (check-procedure-surface obj 'composite-procedure-surface?)
292  (length>1? (%procedure-surface-name obj)))
293
294;;;
295;;; procedure-means
296;;;
297
298;;
299
300(define-inline-unchecked-record-type procedure-means
301  (%make-procedure-means
302    implements immutable loadmode loadname loaded procedure-map symbol-map finalized)
303  %procedure-means?
304  (implements %procedure-means-implements)
305  (immutable %procedure-means-immutable?)
306  (loadmode %procedure-means-loadmode)
307  (loadname %procedure-means-loadname)
308  (loaded %procedure-means-loaded %procedure-means-loaded-set!)
309  (procedure-map %procedure-means-closure-map %procedure-means-closure-map-set!)
310  (symbol-map %procedure-means-identifier-map %procedure-means-identifier-map-set!)
311  (finalized %procedure-means-finalized? %procedure-means-finalized-set!) )
312
313;;
314
315(define-inline (check-procedure-means obj loc)
316  (unless (%procedure-means? obj)
317    (error loc "not a procedure-means" obj)) )
318
319;;
320
321(define-inline (check-procedure-means-mutable obj loc)
322  (check-procedure-means obj loc)
323  (when (procedure-means-immutable? obj)
324    (error loc "immutable procedure-means" obj)) )
325
326;;
327
328(define-inline (%check-procedure-means-complete psm loc)
329  (unless (null? (%procedure-means-incompletes psm))
330    (error loc "incomplete immutable procedure-means")) )
331
332;; Returns alias
333
334(define-inline (%procedure-means-alias psm key)
335  (dict-ref (%procedure-means-identifier-map psm) key) )
336
337;; Returns a binding
338
339(define-inline (%procedure-means-ref psm key)
340  (dict-ref (%procedure-means-closure-map psm) key) )
341
342;; Returns a closure, forces load
343
344(define-inline (%procedure-means-closure psm key)
345  (%procedure-means-load psm)
346  (%procedure-means-ref psm key) )
347
348;;
349
350(define-inline (%procedure-means-set! psm cm im)
351  (%procedure-means-finalized-set! psm #f)
352  (dict-merge! (%procedure-means-closure-map psm) cm)
353  (dict-merge! (%procedure-means-identifier-map psm) im) )
354
355;;
356
357(define-inline (%procedure-means-delete! psm key)
358  (dict-delete! (%procedure-means-closure-map psm) key)
359  (dict-delete! (%procedure-means-identifier-map psm) key) )
360
361;;
362
363(define-inline (%procedure-means-loaded? psm)
364  (not (memq #f (%procedure-means-loaded psm))) )
365
366;;
367
368(define (procedure-identifier->closure sym)
369  (unless (symbol? sym)
370    (error 'procedure-identifier->closure "invalid symbol" sym) )
371  (symbol-value sym) )
372
373;;
374
375(define DEFAULT-CLOSURE-TAG (gensym))
376
377;;
378
379(define-inline (default-closure? obj)
380  (and (extended-procedure? obj)
381       (eq? DEFAULT-CLOSURE-TAG (procedure-data obj))) )
382
383;; Autoload on 1st call. Successful load will call-thru, otherwise an error.
384;;
385;; Note that subsequent closure references will be to the loaded procedure
386;; & not this default.
387
388(define (make-default-closure psm sym)
389  (extend-procedure
390    (lambda args
391      ; Get the procedure
392      (let ([proc (%procedure-means-closure psm sym)])
393        ; Load could fail, otherwise call-thru
394        (if (default-closure? proc)
395            (error "incomplete procedure; not loaded" sym)
396            (apply proc args))))
397    DEFAULT-CLOSURE-TAG))
398
399;; Returns procedure symbols in the surface w/o an alias in the means
400
401(define (%procedure-means-incompletes psm)
402  (let ([incmplts '()])
403    (for-each
404      (lambda (ps)
405        (dict-for-each
406          (%procedure-surface-signature-map ps)
407          (lambda (sym sig)
408            (unless (%procedure-means-alias psm sym)
409              (set! incmplts (alist-cons sym ps incmplts))))))
410      (%procedure-means-implements psm))
411    incmplts))
412
413;; Returns procedure symbols in the surface w/o a binding in the means
414
415(define (%procedure-means-unbounds psm)
416  (let ([unbnds '()])
417    (for-each
418      (lambda (ps)
419        (dict-for-each
420          (%procedure-surface-signature-map ps)
421          (lambda (sym sig)
422            (when (default-closure? (%procedure-means-ref psm sym))
423              (set! unbnds (alist-cons sym ps unbnds))))))
424      (%procedure-means-implements psm))
425    unbnds))
426
427;; Resolve to closure for each procedure symbol
428
429(define (resolve-closures psm)
430  (let ([cm (%procedure-means-closure-map psm)])
431    (dict-for-each
432      cm
433      (lambda (sym cls)
434        (when (default-closure? cls)
435          (let ([alias (%procedure-means-alias psm sym)])
436            (unless alias
437              (error "incomplete procedure; missing alias" sym))
438            (and-let* ([cls (symbol-value alias)])
439              (dict-set! cm sym cls))))))))
440
441;;
442
443(define (perform-load psm)
444  (let ([loadeds '()])
445    ; Load any missing units
446    (for-each
447      (lambda (loadmode loadname loaded?)
448        (unless loaded?
449          (let ([unitname (car loadname)]
450                [pathname (cdr loadname)])
451            (switch loadmode
452              ['extension
453                (if pathname
454                    (load pathname)
455                    (require unitname) )]
456              ['library
457                (apply load-library unitname (or pathname '()))]) ) )
458          ; (load & require will abort so won't get here when failure)
459        ; This one loaded
460        (set! loadeds (cons #t loadeds)) )
461      (%procedure-means-loadmode psm)
462      (%procedure-means-loadname psm)
463      (%procedure-means-loaded psm))
464    ; Should have everything now
465    (resolve-closures psm)
466    ; Record loaded status
467    (%procedure-means-loaded-set! psm (reverse! loadeds))))
468
469;; Performs load if needed
470
471(define (%procedure-means-load psm)
472  (or (%procedure-means-finalized? psm)
473      (begin
474        ; Load all outstanding externals
475        (perform-load psm)
476        ; When nonthing unbound change to fully loaded state
477        (and (null? (%procedure-means-unbounds psm))
478             (null? (%procedure-means-incompletes psm))
479             (begin (%procedure-means-finalized-set! psm #t) #t) ) ) ) )
480
481;;
482
483(define (parse-procedure-identifier-mapping pim psm)
484  (let loop ([pim pim] [pal '()] [sal '()])
485    (if (null? pim)
486        ;then finished
487      (values (alist->dict pal) (alist->dict sal))
488        ;else parse rest
489      (let ([sym (car pim)]
490            [rst (cdr pim)])
491        (unless (symbol? sym)
492          (error "procedure identifier must be a symbol" sym))
493        (when (null? rst)
494          (error "missing procedure alias" sym))
495        (let ([alias (car rst)]
496              [cls #f])
497          (cond [(boolean? alias)
498                  (set! alias sym)
499                  (set! cls (symbol-value alias))]
500                [(procedure? alias)
501                  (set! cls alias)
502                  (set! alias '<procedure>)]
503                [(not (symbol? alias))
504                  (error "procedure alias must be a symbol, procedure, or boolean" sym alias)])
505          ; Need a closure?
506          (unless cls
507            (set! cls (make-default-closure psm sym)))
508          (loop (cdr rst) (alist-cons sym cls pal) (alist-cons sym alias sal)))))))
509
510;;
511
512(define (make-procedure-means implements
513          #!rest procedure-identifier-mapping
514          #!key (immutable #f) (extension #f) (library #f) (pathname #f))
515  ; Implementing something valid?
516  (check-procedure-surface implements 'make-procedure-means)
517  ; Can only deal w/ a unitary procedure-surface
518  (when (length>1? (%procedure-surface-name implements))
519    (error 'make-procedure-means
520      "use 'make-composite-procedure-means' for a composite-procedure-surface") )
521  ;
522  (when pathname
523    (unless (string? pathname)
524      (error 'make-procedure-means "invalid pathname" pathname) ) )
525  ;
526  (let ([unitspec (or extension library)])
527    ; Disambiguate
528    (when (and library extension)
529      (error 'make-procedure-means "cannot be library and extension") )
530    ; Proper unit specification?
531    (unless (or (not unitspec)
532                (and (symbol? unitspec) (not (keyword? unitspec)))
533                (string? unitspec)
534                (boolean? unitspec))
535      (error 'make-procedure-means "invalid unitname" unitspec) )
536    ; Create procedure interface item
537    (let* (
538        [unitname
539          (cond [(boolean? unitspec)
540                  (%procedure-surface-name implements)]
541                [(string? unitspec)
542                  (string->symbol unitspec)]
543                [else
544                  unitspec])]
545        [psm
546          (%make-procedure-means
547            `(,implements)
548            immutable
549            `(,(or (and extension 'extension) (and library 'library)))
550            `((,unitname . ,pathname))
551            `(#f)
552            #f
553            #f
554            #f)])
555      (let-values (
556          ([plt slt]
557            (parse-procedure-identifier-mapping
558              (fixup-extended-lambda-list-rest
559               '(#:immutable #:extension #:library #:pathname)
560               procedure-identifier-mapping)
561              psm)))
562        (%procedure-means-closure-map-set! psm plt)
563        (%procedure-means-identifier-map-set! psm slt)
564        ;
565        (when immutable
566          (%check-procedure-means-complete psm 'make-procedure-means))
567        ;
568        psm ) ) ) )
569
570;;
571
572(define (procedure-means? obj)
573  (%procedure-means? obj))
574
575;;
576
577(define (procedure-means-immutable? obj)
578  (check-procedure-means obj 'procedure-means-immutable?)
579  (%procedure-means-immutable? obj))
580
581;;
582
583(define (procedure-means-mutable? obj)
584  (check-procedure-means obj 'procedure-means-mutable?)
585  (not (%procedure-means-immutable? obj)))
586
587;;
588
589(define (procedure-means-complete? obj)
590  (check-procedure-means obj 'procedure-means-complete?)
591  (null? (%procedure-means-incompletes obj)))
592
593;;
594
595(define (procedure-means-incompletes obj)
596  (check-procedure-means obj 'procedure-means-incompletes)
597  (%procedure-means-incompletes obj))
598
599;;
600
601(define (procedure-means-bound? obj)
602  (check-procedure-means obj 'procedure-means-bound?)
603  (null? (%procedure-means-unbounds obj)))
604
605;;
606
607(define (procedure-means-unbounds obj)
608  (check-procedure-means obj 'procedure-means-unbounds)
609  (%procedure-means-unbounds obj))
610
611;;
612
613(define (procedure-means-implements obj)
614  (check-procedure-means obj 'procedure-means-implements)
615  (let ([implements (%procedure-means-implements obj)])
616    (or (and (length=1? implements) (car implements))
617        (list-copy implements))))
618
619;; Returns alias
620
621(define (procedure-means-alias obj key)
622  (check-procedure-means obj 'procedure-means-alias)
623  (%procedure-means-alias obj key))
624
625;; Returns a binding
626
627(define (procedure-means-ref obj key)
628  (check-procedure-means obj 'procedure-means-ref)
629  (%procedure-means-ref obj key))
630
631;; Returns a closure, forces load
632
633(define (procedure-means-closure obj key)
634  (check-procedure-means obj 'procedure-means-closure)
635  (%procedure-means-closure obj key))
636
637;; Creates or updates one or more procedure & identifier mappings
638
639(define (procedure-means-set! obj #!rest pim)
640  (check-procedure-means-mutable obj 'procedure-means-set!)
641  (let-values (([plt slt] (parse-procedure-identifier-mapping pim obj)))
642    (%procedure-means-set! obj plt slt)))
643
644;; Removes a  procedure & identifier mappings. Does not complain when key has no match.
645
646(define (procedure-means-delete! obj key)
647  (check-procedure-means-mutable obj 'procedure-means-delete!)
648  (%procedure-means-delete! obj key))
649
650;;
651
652(define (procedure-means->alist obj)
653  (check-procedure-means obj 'procedure-means->alist)
654  (list-copy (dict->alist (%procedure-means-closure-map obj))))
655
656;; Combination w/o overlap (pure union)
657;; If any of the combined procedure means is immutable
658;; then the composite is immutable.
659
660(define (make-composite-procedure-means . rest)
661  ; Start with nothing
662  (let ([pal '()]
663        [sal '()]
664        [loadmodes '()]
665        [loadnames '()]
666        [implements '()]
667        [loadeds '()]
668        [immutable #f])
669    ; Accumulate the information from the procedure meanss
670    (let loop ([psm-lst rest])
671      (unless (null? psm-lst)
672        (let ([psm (car psm-lst)])
673          ; Supposed to be a procedure-means
674          (check-procedure-means psm 'make-composite-procedure-means)
675          ; Propagate immutable contagion
676          (unless immutable
677            (set! immutable (%procedure-means-immutable? psm)))
678          ; Process every P of the PII
679          (dict-for-each
680            (%procedure-means-closure-map psm)
681            (lambda (sym cls)
682              (when (alist-ref sym pal eq?)
683                (errorf 'make-composite-procedure-means
684                  "procedure '~A' multiply defined" sym))
685              (set! pal (alist-cons sym cls pal))))
686          ; Process every S->A of the PII
687          (dict-for-each
688            (%procedure-means-identifier-map psm)
689              (lambda (sym alias)
690                (when (alist-ref sym sal eq?)
691                  (errorf 'make-composite-procedure-means
692                    "procedure '~A' multiply defined" sym))
693                (set! sal (alist-cons sym alias sal))))
694          ; Collect load information
695          (set! loadmodes (append loadmodes (%procedure-means-loadmode psm)))
696          (set! loadnames (append loadnames (%procedure-means-loadname psm)))
697          (set! loadeds (append loadeds (%procedure-means-loaded psm)))
698          ; Collect implements information
699          (set! implements (append implements (%procedure-means-implements psm)))
700        (loop (cdr psm-lst))))
701    ; Composition done
702    (let (
703        [cpsm
704          (%make-procedure-means
705            implements
706            immutable
707            loadmodes
708            loadnames
709            loadeds
710            (alist->dict pal)
711            (alist->dict sal)
712            #f)])
713      ;
714      (when immutable
715        (%check-procedure-means-complete cpsm 'make-composite-procedure-means))
716      ;
717      cpsm))))
718
719;;
720
721(define (composite-procedure-means? obj)
722  (check-procedure-means obj 'composite-procedure-means?)
723  (let ([implements (%procedure-means-implements obj)])
724    (length>1? implements)))
725
726;; Peform any needed loading & return #t or #f
727
728(define (procedure-means-load! obj)
729  (check-procedure-means obj 'procedure-means-load!)
730  (unless (%procedure-means-load obj)
731    (error 'procedure-means-load "load incomplete")))
732
733;; Is this procedure loaded?
734
735(define (procedure-unbound? obj)
736  (default-closure? obj) )
737
738;; Does this procedure have an alias?
739
740(define (procedure-means-incomplete-closure? obj sym)
741  (check-procedure-means obj 'procedure-means-incomplete-closure?)
742  (and (alist-ref sym (%procedure-means-incompletes obj) eq?)
743       #t) )
Note: See TracBrowser for help on using the repository browser.