source: project/release/4/datatypes/trunk/datatypes.scm @ 33058

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

datatypes 1.3.1 code beautified

File size: 16.2 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 simplyfies Felix' code by using the facilities of
40; my bindings egg, changes the names and syntax a little and adds
41; abstract as well as object types. Concrete types are variant records
42; as EOPL's datatypes, but constructor arguments can accept zero or more
43; predicates, abstract types hide the constructors of its implementing
44; concrete types like the corresponding language construct of ML, and
45; object types are message-handlers, where the messages are defined as
46; concrete-types.
47
48(module datatypes (define-concrete-type
49                  (concrete-case invoke)
50                  define-abstract-type
51                  define-object-type
52                  make-base-object
53                  object?
54                  Types
55                  Info
56                  Invariant
57                  Ancestors
58                  datatypes)
59
60  (import scheme chicken
61          (only data-structures conjoin list-of?))
62  (import-for-syntax (only chicken assert))
63
64;;; (define-concrete-type TYPE type?
65;;;   (Constructor (arg pred ...) ...)
66;;;   ....)
67;;; ---------------------------------- 
68;;; defines a new annotated union type TYPE
69;;; with predicate type? by means of constructors
70;;; Constructor ..., whose arguments arg ... are
71;;; checked by predicates pred ...
72;;; The arguments arg ... can be extracted by means
73;;; of concrete-case below.
74(define-syntax define-concrete-type
75  (ir-macro-transformer
76    (lambda (form inject compare?)
77      (let ((TYPE (cadr form))
78            (type? (caddr form))
79            (variants (cdddr form)))
80        (assert (pair? variants))
81        (assert ((list-of? pair?) variants))
82        (assert ((list-of? symbol?) (map car variants)))
83        `(begin
84           (define (,type? form)
85             (##sys#structure? form ',TYPE))
86           ,@(map (lambda (variant)
87                    (let ((variantname (car variant))
88                          (checkedargs (cdr variant)))
89                      (let ((variantargs (map car checkedargs))
90                            (variantpreds (map cdr checkedargs)))
91                        `(define (,variantname ,@variantargs)
92                           (##sys#make-structure
93                            ',TYPE ',variantname
94                            ,@(map (lambda (name pred)
95                                     `(if (##core#check (,pred ,name))
96                                        ,name
97                                        (##sys#signal-hook
98                                         #:type-error 
99                                         "bad argument type to variant constructor"
100                                         ,name ',variantname ',name)))
101                                   variantargs
102                                   (map (lambda (preds)
103                                          `(conjoin ,@preds))
104                                                    variantpreds)))))))
105                  variants))))))
106
107;;; (concrete-case (obj type?)
108;;;   ((Constructor arg ...) xpr ....)
109;;;   ...
110;;;   (else ypr ....) ..)
111;;; ----------------------------------
112;;; destructures an object, obj, of a concrete type
113;;; with predicate type? by examining its constructors
114;;; in a case fashion.
115;;; Evaluates the body xpr .... with access to arg ...
116;;; of the first matching constructor or the body ypr ....
117;;; if no constructor matches.
118(define-syntax concrete-case
119  (ir-macro-transformer
120    (lambda (form inject compare?)
121      (let ((pair (cadr form))
122            (clauses (cddr form)))
123        (assert (pair? clauses))
124        (assert ((list-of? pair?) clauses))
125        (assert ((list-of? pair?) (map cdr clauses)))
126        (assert ((list-of? (lambda (x)
127                             (or (compare? x 'else)
128                                 (and (pair? x)
129                                      (symbol? (car x))))))
130                 (map car clauses)))
131        (let ((xpr (car pair))
132              (type? (cadr pair)))
133          `(let ((tmp ,xpr))
134             (if (##core#check (,type? tmp))
135               (let ((tag (##sys#slot tmp 1)))
136                 (cond ,@(map (lambda (clause)
137                                (let ((first (car clause))
138                                      (xpr (cadr clause))
139                                      (xprs (cddr clause)))
140                                  (if (pair? first)
141                                    (let ((variantname (car first))
142                                          (variantargs (cdr first)))
143                                      `((eq? tag ',variantname)
144                                        (invoke
145                                          ',variantname tmp 
146                                          ,(length variantargs) 
147                                          (lambda ,variantargs
148                                            ,xpr ,@xprs))))
149                                    `(else (let () ,xpr ,@xprs)))))
150                              clauses)))
151               (##sys#signal-hook #:type-error
152                "typecheck didn't pass in concrete-case"
153                `(,',type?  ,tmp)))))))))
154
155(define (invoke name block count proc)
156  (apply
157   proc
158   (let ((limit (fx- (##sys#size block) 2)))
159     (let rec ((i 0))
160       (cond
161         ((fx>= i count) '())
162         ((fx>= i limit) (error 'concrete-case
163                                "too many record fields accessed"
164                                name block))
165         (else (cons (##sys#slot block (fx+ i 2))
166                     (rec (fx+ i 1)))))))))
167
168;;; (define-abstract-type TYPE type?
169;;;   (Constructor (arg pred ...) ...)
170;;;   ....
171;;;   (with
172;;;     ((proc arg ...) xpr ....)
173;;;     ....)
174;;;   (printer print-proc) ..
175;;;   (reader  read-proc) ..)
176;;; ----------------------------------
177;;; same as define-concrete-type, but constructors
178;;; Consetructor ... are hidden and only available
179;;; in the exported procedures proc .... with body
180;;; xpr .... as well as in print-proc and read-proc
181;;; if the latter are supplied.
182(define-syntax define-abstract-type
183  (ir-macro-transformer
184    (lambda (form inject compare?)
185      (let ((TYPE (cadr form))
186            (type? (caddr form))
187            (rest (reverse (cdddr form))))
188        (cond
189          ((compare? (caar rest) 'reader)
190           (define variants (reverse (list-tail rest 3)))
191           (define routines (cdr (list-ref rest 2)))
192           (define printer (cadr (list-ref rest 1)))
193           (define reader (cadr (list-ref rest 0))))
194          ((compare? (caar rest) 'printer)
195           (define variants (reverse (list-tail rest 2)))
196           (define routines (cdr (list-ref rest 1)))
197           (define printer (cadr (list-ref rest 0)))
198           (define reader #f))
199          ((compare? (caar rest) 'with)
200           (define variants (reverse (list-tail rest 1)))
201           (define routines (cdr (list-ref rest 0)))
202           (define printer #f) 
203           (define reader #f))
204          (else
205            (error 'define-abstract-type "syntax error")))
206        (assert (pair? variants))
207        (assert ((list-of? pair?) variants))
208        (assert (pair? routines))
209        (assert ((list-of? pair?) routines))
210        (let ((names (map caar routines))
211              (args (map cdar routines))
212              (bodies (map cdr routines)))
213          `(define-values (,type?  ,@names)
214             (letrec ,(map (lambda (n) `(,n #f)) names)
215               (define-concrete-type ,TYPE ,type? ,@variants)
216               ,@(map (lambda (n a b) `(set! ,n (lambda ,a ,@b)))
217                      names args bodies)
218               ,(if printer
219                  `(define-record-printer ,TYPE ,printer))
220               ,(if reader
221                  `(define-reader-ctor ',TYPE ,reader))
222               (values ,type? ,@names))))))))
223
224;;; (define-object-type CHILD child? make-child
225;;;   ((parent parent?) (x x? ...) ...)      ; state variables
226;;;   (override  ((A a ...) apr ....) ...)   ; overridden messages
227;;;   ((X (x x? ...) ...) xpr ....)          ; new messages
228;;;   ....)
229;;; -------------------------------------------
230;;; defines an object type CHILD with predicate child?
231;;; and constructor make-child with state variables
232;;; parent checked by the parent? predicate and x
233;;; checked by x? ...
234;;; New messages of arguments x ... checked by x? ...
235;;; and body xpr .... are X and overriden messages of
236;;; arguments a ... without checks but body apr ....
237;;; are A ...
238(define-syntax define-object-type
239  (ir-macro-transformer
240    (lambda (form inject compare?)
241      (let ((CHILD (list-ref form 1))
242            (child? (list-ref form 2))
243            (make-child (list-ref form 3))
244            (parent-clause (list-ref form 4))
245            (override-clause (list-ref form 5))
246            (body (list-tail form 6)))
247        (assert (pair? parent-clause))
248        (assert (pair? (car parent-clause)))
249        (assert (pair? override-clause))
250        (assert (compare? (car override-clause) 'override))
251        (assert (pair? body))
252        (assert ((list-of? pair?) (map car body)))
253        (assert ((list-of? symbol?) (map caar body)))
254        (assert ((list-of? pair?) (map cdr body)))
255        (let ((parent-pair (car parent-clause))
256              (xss (cdr parent-clause))
257              (obody (cdr override-clause)))
258          (pair? xss)
259          ((list-of? pair?) xss)
260          (assert ((list-of? pair?) (map car obody)))
261          (assert ((list-of? symbol?) (map caar obody)))
262          (assert ((list-of? pair?) (map cdr obody)))
263     (let ((parent (car parent-pair))
264           (parent? (cadr parent-pair))
265           (xs (map car xss))
266           (xs? (map (lambda (ps) `(conjoin ,@ps))
267                     (map cdr xss)))
268           (messages (map car body))
269           (omessages (map car obody))
270           (extract-args (lambda (as)
271                           (if ((list-of? symbol?) as)
272                             as
273                             (map car as)))))
274       (let ((message-names (append (map car omessages)
275                                    (map car messages)))
276             (arg-names
277               (append (map extract-args (map cdr omessages))
278                       (map extract-args (map cdr messages))))
279             (Types (inject 'Types))
280             (Invariant (inject 'Invariant))
281             (Info (inject 'Info))
282             (Ancestors (inject 'Ancestors)))
283         `(define-values (,make-child ,child? ,@message-names)
284            (let ((type (gensym ',CHILD)))
285              ;; note, that the MSG type is distributed over the whole
286              ;; object hierarchy, since the parents, including object,
287              ;; all implement this type locally with the same name.
288              ;; This is the reason, that the else clause in
289              ;; concrete-case branches to the parent.
290              (define-concrete-type MSG msg?
291                ;;; only new messages
292                ,@messages)
293              (values
294                ;; constructor
295                (lambda (,parent ,@xs)
296                  (let ((,parent ,parent) ,@(map (lambda (x) `(,x ,x)) xs))
297                    (lambda (msg)
298                      (concrete-case (msg msg?)
299                        ;; automatic overrides
300                        ((,Types)
301                         (cons type (,parent (,Types))))
302                        ((,Invariant)
303                         (if (and (,parent (,Invariant))
304                                  ,@(map (lambda (n p)
305                                           `(,p ,n))
306                                         xs xs?))
307                           '(and (,parent (,Invariant))
308                                 ,@xss)
309                           #f))
310                        ((,Info)
311                         (append (,parent (,Info))
312                                 ',messages))
313                        ((,Ancestors)
314                         (cons ,parent (,parent (,Ancestors))))
315                        ;; overriden and new messages
316                        ,@(map (lambda (n as bs) `((,n ,@as) ,@bs))
317                               message-names
318                               arg-names
319                               (map cdr (append obody body)))
320                        (else (,parent msg))))))
321                ;; predicate
322                (lambda (xpr)
323                  (and (procedure? xpr)
324                       (condition-case (if (memq type (xpr (,Types)))
325                                         #t
326                                         #f)
327                         ((exn) #f))))
328                ;; messages
329                ,@message-names))))))))))
330
331;;; (make-base-object)
332;;; ------------------
333;;; creates the base objecto of type predicate object? from
334;;; which all other objects inherit.
335;;; (object? xpr)
336;;; -------------
337;;; type predicate
338;;; (Types)
339;;; -------
340;;; shows the path of types
341;;; (Info)
342;;; -------
343;;; shows the list of available messages
344;;; (Invariant)
345;;; -----------
346;;; tests and shows the invariant
347;;; (Ancestors)
348;;; -----------
349;;; list of ancestor objects
350(define-values (make-base-object object? Types Info Invariant Ancestors) 
351  (let ((type (gensym 'OBJECT)))
352    (define-concrete-type MSG msg?
353      (Types)
354      (Info)
355      (Invariant)
356      (Ancestors))
357    (values
358      ;; constructor
359      (lambda ()
360        (lambda (msg)
361          (concrete-case (msg msg?)
362            ((Types) (list type))
363            ((Info) '((Types) (Info) (Invariant) (Ancestors)))
364            ((Invariant) '())
365            ((Ancestors) '()))))
366      ;; predicate
367      (lambda (xpr)
368        (and (procedure? xpr)
369             (condition-case (if (memq type (xpr (Types))) #t #f)
370               ((exn) #f))))
371      ;; messages
372      Types
373      Info
374      Invariant
375      Ancestors)))
376
377;; documentation procedure
378(define datatypes
379  (let (
380    (signatures '(
381      (define-concrete-type TYPE type?
382        (Constructor (arg arg? ...) ...)
383        ....)
384      (concrete-case (obj type?)
385        ((Constructor arg ...) xpr . xprs)
386        ....
387        (else xpr . xprs) ..)
388      (define-abstract-type TYPE type?
389        (Constructor (arg arg? ...) ...)
390        ....
391        (with
392          ((proc . args) xpr . xprs)
393          ....)
394        (printer (lambda (obj out) xpr . xprs))
395        ..
396        (reader proc)
397        ..)
398      (define-object-type CHILD child? make-child
399        ((parent parent?) (x x? ...) ...)      ; state variables
400        (override  ((A a ...) apr . aprs) ...) ; overridden messages
401        ((X (x x? ...) ...) xpr . xprs)        ; new messages
402        ....)
403      (make-base-object)
404      (object? xpr)
405      (Types)
406      (Info)
407      (Invariant)
408      (Ancestors)
409      ))
410    )
411    (case-lambda
412      (() (map car signatures))
413      ((sym) (assq sym signatures)))))
414
415) ; module datatypes
416         
Note: See TracBrowser for help on using the repository browser.