source: project/release/4/datatypes/tags/1.3.3/datatypes.scm @ 33753

Last change on this file since 33753 was 33753, checked in by juergen, 3 years ago

datatypes 1.3.3 fixed typo

File size: 16.1 KB
Line 
1#|[
2Author: Juergen Lorenz
3ju (at) jugilo (dot) de
4
5Copyright (c) 2015-2016, Juergen Lorenz
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions are
10met:
11
12Redistributions of source code must retain the above copyright
13notice, this list of conditions and the following disclaimer.
14
15Redistributions in binary form must reproduce the above copyright
16notice, this list of conditions and the following disclaimer in the
17documentation and/or other materials provided with the distribution.
18
19Neither the name of the author nor the names of its contributors may be
20used to endorse or promote products derived from this software without
21specific prior written permission.
22
23THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
26PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
27HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
29TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34]|#
35
36; This is a variant of the datatype egg, written by Felix Winkelmann,
37; which in turn is patterned after the datatype facility described in
38; the classic "Essentials of programming languages" (EOPL) by Friedman,
39; Wand and Haynes. It changes the names and syntax a little and adds
40; abstract as well as object types. Concrete types are variant records
41; as EOPL's datatypes, but constructor arguments can accept zero or more
42; predicates, abstract types hide the constructors of its implementing
43; concrete types like the corresponding language construct of ML, and
44; object types are message-handlers, where the messages are defined as
45; concrete-types.
46
47(module datatypes (define-concrete-type
48                  (concrete-case invoke)
49                  define-abstract-type
50                  define-object-type
51                  make-base-object
52                  object?
53                  Types
54                  Info
55                  Invariant
56                  Ancestors
57                  datatypes)
58
59  (import scheme chicken
60          (only data-structures conjoin list-of?))
61  (import-for-syntax (only chicken assert))
62
63;;; (define-concrete-type TYPE type?
64;;;   (Constructor (arg pred ...) ...)
65;;;   ....)
66;;; ---------------------------------- 
67;;; defines a new annotated union type TYPE
68;;; with predicate type? by means of constructors
69;;; Constructor ..., whose arguments arg ... are
70;;; checked by predicates pred ...
71;;; The arguments arg ... can be extracted by means
72;;; of concrete-case below.
73(define-syntax define-concrete-type
74  (ir-macro-transformer
75    (lambda (form inject compare?)
76      (let ((TYPE (cadr form))
77            (type? (caddr form))
78            (variants (cdddr form)))
79        (assert (pair? variants))
80        (assert ((list-of? pair?) variants))
81        (assert ((list-of? symbol?) (map car variants)))
82        `(begin
83           (define (,type? form)
84             (##sys#structure? form ',TYPE))
85           ,@(map (lambda (variant)
86                    (let ((variantname (car variant))
87                          (checkedargs (cdr variant)))
88                      (let ((variantargs (map car checkedargs))
89                            (variantpreds (map cdr checkedargs)))
90                        `(define (,variantname ,@variantargs)
91                           (##sys#make-structure
92                            ',TYPE ',variantname
93                            ,@(map (lambda (name pred)
94                                     `(if (##core#check (,pred ,name))
95                                        ,name
96                                        (##sys#signal-hook
97                                         #:type-error 
98                                         "bad argument type to variant constructor"
99                                         ,name ',variantname ',name)))
100                                   variantargs
101                                   (map (lambda (preds)
102                                          `(conjoin ,@preds))
103                                                    variantpreds)))))))
104                  variants))))))
105
106;;; (concrete-case (obj type?)
107;;;   ((Constructor arg ...) xpr ....)
108;;;   ...
109;;;   (else ypr ....) ..)
110;;; ----------------------------------
111;;; destructures an object, obj, of a concrete type
112;;; with predicate type? by examining its constructors
113;;; in a case fashion.
114;;; Evaluates the body xpr .... with access to arg ...
115;;; of the first matching constructor or the body ypr ....
116;;; if no constructor matches.
117(define-syntax concrete-case
118  (ir-macro-transformer
119    (lambda (form inject compare?)
120      (let ((pair (cadr form))
121            (clauses (cddr form)))
122        (assert (pair? clauses))
123        (assert ((list-of? pair?) clauses))
124        (assert ((list-of? pair?) (map cdr clauses)))
125        (assert ((list-of? (lambda (x)
126                             (or (compare? x 'else)
127                                 (and (pair? x)
128                                      (symbol? (car x))))))
129                 (map car clauses)))
130        (let ((xpr (car pair))
131              (type? (cadr pair)))
132          `(let ((tmp ,xpr))
133             (if (##core#check (,type? tmp))
134               (let ((tag (##sys#slot tmp 1)))
135                 (cond ,@(map (lambda (clause)
136                                (let ((first (car clause))
137                                      (xpr (cadr clause))
138                                      (xprs (cddr clause)))
139                                  (if (pair? first)
140                                    (let ((variantname (car first))
141                                          (variantargs (cdr first)))
142                                      `((eq? tag ',variantname)
143                                        (invoke
144                                          ',variantname tmp 
145                                          ,(length variantargs) 
146                                          (lambda ,variantargs
147                                            ,xpr ,@xprs))))
148                                    `(else (let () ,xpr ,@xprs)))))
149                              clauses)))
150               (##sys#signal-hook #:type-error
151                "typecheck didn't pass in concrete-case"
152                `(,',type?  ,tmp)))))))))
153
154(define (invoke name block count proc)
155  (apply
156   proc
157   (let ((limit (fx- (##sys#size block) 2)))
158     (let rec ((i 0))
159       (cond
160         ((fx>= i count) '())
161         ((fx>= i limit) (error 'concrete-case
162                                "too many record fields accessed"
163                                name block))
164         (else (cons (##sys#slot block (fx+ i 2))
165                     (rec (fx+ i 1)))))))))
166
167;;; (define-abstract-type TYPE type?
168;;;   (Constructor (arg pred ...) ...)
169;;;   ....
170;;;   (with
171;;;     ((proc arg ...) xpr ....)
172;;;     ....)
173;;;   (printer print-proc) ..
174;;;   (reader  read-proc) ..)
175;;; ----------------------------------
176;;; same as define-concrete-type, but constructors
177;;; Consetructor ... are hidden and only available
178;;; in the exported procedures proc .... with body
179;;; xpr .... as well as in print-proc and read-proc
180;;; if the latter are supplied.
181(define-syntax define-abstract-type
182  (ir-macro-transformer
183    (lambda (form inject compare?)
184      (let ((TYPE (cadr form))
185            (type? (caddr form))
186            (rest (reverse (cdddr form))))
187        (cond
188          ((compare? (caar rest) 'reader)
189           (define variants (reverse (list-tail rest 3)))
190           (define routines (cdr (list-ref rest 2)))
191           (define printer (cadr (list-ref rest 1)))
192           (define reader (cadr (list-ref rest 0))))
193          ((compare? (caar rest) 'printer)
194           (define variants (reverse (list-tail rest 2)))
195           (define routines (cdr (list-ref rest 1)))
196           (define printer (cadr (list-ref rest 0)))
197           (define reader #f))
198          ((compare? (caar rest) 'with)
199           (define variants (reverse (list-tail rest 1)))
200           (define routines (cdr (list-ref rest 0)))
201           (define printer #f) 
202           (define reader #f))
203          (else
204            (error 'define-abstract-type "syntax error")))
205        (assert (pair? variants))
206        (assert ((list-of? pair?) variants))
207        (assert (pair? routines))
208        (assert ((list-of? pair?) routines))
209        (let ((names (map caar routines))
210              (args (map cdar routines))
211              (bodies (map cdr routines)))
212          `(define-values (,type?  ,@names)
213             (letrec ,(map (lambda (n) `(,n #f)) names)
214               (define-concrete-type ,TYPE ,type? ,@variants)
215               ,@(map (lambda (n a b) `(set! ,n (lambda ,a ,@b)))
216                      names args bodies)
217               ,(if printer
218                  `(define-record-printer ,TYPE ,printer))
219               ,(if reader
220                  `(define-reader-ctor ',TYPE ,reader))
221               (values ,type? ,@names))))))))
222
223;;; (define-object-type CHILD child? make-child
224;;;   ((parent parent?) (x x? ...) ...)      ; state variables
225;;;   (override  ((A a ...) apr ....) ...)   ; overridden messages
226;;;   ((X (x x? ...) ...) xpr ....)          ; new messages
227;;;   ....)
228;;; -------------------------------------------
229;;; defines an object type CHILD with predicate child?
230;;; and constructor make-child with state variables
231;;; parent checked by the parent? predicate and x
232;;; checked by x? ...
233;;; New messages of arguments x ... checked by x? ...
234;;; and body xpr .... are X and overriden messages of
235;;; arguments a ... without checks but body apr ....
236;;; are A ...
237(define-syntax define-object-type
238  (ir-macro-transformer
239    (lambda (form inject compare?)
240      (let ((CHILD (list-ref form 1))
241            (child? (list-ref form 2))
242            (make-child (list-ref form 3))
243            (parent-clause (list-ref form 4))
244            (override-clause (list-ref form 5))
245            (body (list-tail form 6)))
246        (assert (pair? parent-clause))
247        (assert (pair? (car parent-clause)))
248        (assert (pair? override-clause))
249        (assert (compare? (car override-clause) 'override))
250        (assert (pair? body))
251        (assert ((list-of? pair?) (map car body)))
252        (assert ((list-of? symbol?) (map caar body)))
253        (assert ((list-of? pair?) (map cdr body)))
254        (let ((parent-pair (car parent-clause))
255              (xss (cdr parent-clause))
256              (obody (cdr override-clause)))
257          (pair? xss)
258          ((list-of? pair?) xss)
259          (assert ((list-of? pair?) (map car obody)))
260          (assert ((list-of? symbol?) (map caar obody)))
261          (assert ((list-of? pair?) (map cdr obody)))
262     (let ((parent (car parent-pair))
263           (parent? (cadr parent-pair))
264           (xs (map car xss))
265           (xs? (map (lambda (ps) `(conjoin ,@ps))
266                     (map cdr xss)))
267           (messages (map car body))
268           (omessages (map car obody))
269           (extract-args (lambda (as)
270                           (if ((list-of? symbol?) as)
271                             as
272                             (map car as)))))
273       (let ((message-names (append (map car omessages)
274                                    (map car messages)))
275             (arg-names
276               (append (map extract-args (map cdr omessages))
277                       (map extract-args (map cdr messages))))
278             (Types (inject 'Types))
279             (Invariant (inject 'Invariant))
280             (Info (inject 'Info))
281             (Ancestors (inject 'Ancestors)))
282         `(define-values (,make-child ,child? ,@message-names)
283            (let ((type (gensym ',CHILD)))
284              ;; note, that the MSG type is distributed over the whole
285              ;; object hierarchy, since the parents, including object,
286              ;; all implement this type locally with the same name.
287              ;; This is the reason, that the else clause in
288              ;; concrete-case branches to the parent.
289              (define-concrete-type MSG msg?
290                ;;; only new messages
291                ,@messages)
292              (values
293                ;; constructor
294                (lambda (,parent ,@xs)
295                  (let ((,parent ,parent) ,@(map (lambda (x) `(,x ,x)) xs))
296                    (lambda (msg)
297                      (concrete-case (msg msg?)
298                        ;; automatic overrides
299                        ((,Types)
300                         (cons type (,parent (,Types))))
301                        ((,Invariant)
302                         (if (and (,parent (,Invariant))
303                                  ,@(map (lambda (n p)
304                                           `(,p ,n))
305                                         xs xs?))
306                           '(and (,parent (,Invariant))
307                                 ,@xss)
308                           #f))
309                        ((,Info)
310                         (append (,parent (,Info))
311                                 ',messages))
312                        ((,Ancestors)
313                         (cons ,parent (,parent (,Ancestors))))
314                        ;; overriden and new messages
315                        ,@(map (lambda (n as bs) `((,n ,@as) ,@bs))
316                               message-names
317                               arg-names
318                               (map cdr (append obody body)))
319                        (else (,parent msg))))))
320                ;; predicate
321                (lambda (xpr)
322                  (and (procedure? xpr)
323                       (condition-case (if (memq type (xpr (,Types)))
324                                         #t
325                                         #f)
326                         ((exn) #f))))
327                ;; messages
328                ,@message-names))))))))))
329
330;;; (make-base-object)
331;;; ------------------
332;;; creates the base objecto of type predicate object? from
333;;; which all other objects inherit.
334;;; (object? xpr)
335;;; -------------
336;;; type predicate
337;;; (Types)
338;;; -------
339;;; shows the path of types
340;;; (Info)
341;;; -------
342;;; shows the list of available messages
343;;; (Invariant)
344;;; -----------
345;;; tests and shows the invariant
346;;; (Ancestors)
347;;; -----------
348;;; list of ancestor objects
349(define-values (make-base-object object? Types Info Invariant Ancestors) 
350  (let ((type (gensym 'OBJECT)))
351    (define-concrete-type MSG msg?
352      (Types)
353      (Info)
354      (Invariant)
355      (Ancestors))
356    (values
357      ;; constructor
358      (lambda ()
359        (lambda (msg)
360          (concrete-case (msg msg?)
361            ((Types) (list type))
362            ((Info) '((Types) (Info) (Invariant) (Ancestors)))
363            ((Invariant) '())
364            ((Ancestors) '()))))
365      ;; predicate
366      (lambda (xpr)
367        (and (procedure? xpr)
368             (condition-case (if (memq type (xpr (Types))) #t #f)
369               ((exn) #f))))
370      ;; messages
371      Types
372      Info
373      Invariant
374      Ancestors)))
375
376;; documentation procedure
377(define datatypes
378  (let (
379    (signatures '(
380      (define-concrete-type TYPE type?
381        (Constructor (arg arg? ...) ...)
382        ....)
383      (concrete-case (obj type?)
384        ((Constructor arg ...) xpr . xprs)
385        ....
386        (else xpr . xprs) ..)
387      (define-abstract-type TYPE type?
388        (Constructor (arg arg? ...) ...)
389        ....
390        (with
391          ((proc . args) xpr . xprs)
392          ....)
393        (printer (lambda (obj out) xpr . xprs))
394        ..
395        (reader proc)
396        ..)
397      (define-object-type CHILD child? make-child
398        ((parent parent?) (x x? ...) ...)      ; state variables
399        (override  ((A a ...) apr . aprs) ...) ; overridden messages
400        ((X (x x? ...) ...) xpr . xprs)        ; new messages
401        ....)
402      (make-base-object)
403      (object? xpr)
404      (Types)
405      (Info)
406      (Invariant)
407      (Ancestors)
408      ))
409    )
410    (case-lambda
411      (() (map car signatures))
412      ((sym) (assq sym signatures)))))
413
414) ; module datatypes
415         
Note: See TracBrowser for help on using the repository browser.