Changeset 33052 in project


Ignore:
Timestamp:
01/07/16 17:23:39 (5 years ago)
Author:
juergen
Message:

datatypes 1.3, bug fix in abstract types, dependencies removed

Location:
release/4/datatypes
Files:
8 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/datatypes/tags/1.3/datatypes.meta

    r32516 r33052  
    22
    33((synopsis
    4    "Creating concrete and abstract types as in ML")
     4   "Creating concrete-, abstract- and object-types")
    55 (category lang-exts)
    66 (license "BSD")
    7  (depends bindings)
    87 (test-depends simple-tests cells)
    98 (author "[[Juergen Lorenz]]")
  • release/4/datatypes/tags/1.3/datatypes.scm

    r32516 r33052  
    33ju (at) jugilo (dot) de
    44
    5 Copyright (c) 2015, Juergen Lorenz
     5Copyright (c) 2015-2016, Juergen Lorenz
    66All rights reserved.
    77
     
    4646; concrete-types.
    4747
    48 (require-library bindings)
    49 
    5048(module datatypes (define-concrete-type
    5149                  (concrete-case invoke)
     
    6058                  datatypes)
    6159
    62   (import scheme chicken bindings
    63           (only data-structures conjoin disjoin o))
    64   (import-for-syntax (only bindings macro-rules bindable? bind-case))
    65 
    66 (define-macro (define-concrete-type TYPE type? . variants)
    67   (where ((list-of? list?) variants)
    68          (not (null? variants))
    69          ((list-of? symbol?) (map car variants))
    70          ((list-of? list?) (map cdr variants)))
    71   `(begin
    72      (define (,type? form) (##sys#structure? form ',TYPE))
    73      ,@(map (lambda (variant)
    74               (bind-case variant
    75                 ((variantname . checkedargs)
    76                  (let ((variantargs (map car checkedargs))
    77                        (variantpreds (map cdr checkedargs)))
    78                    `(define (,variantname ,@variantargs)
    79                       (##sys#make-structure
    80                        ',TYPE ',variantname
    81                        ,@(map (lambda (name pred)
    82                                 `(if (##core#check (,pred ,name))
    83                                    ,name
    84                                    (##sys#signal-hook
    85                                     #:type-error
    86                                     "bad argument type to variant constructor"
    87                                     ,name ',variantname ',name)))
    88                               variantargs (map (lambda (preds)
    89                                                  `(conjoin ,@preds))
    90                                                variantpreds))))))))
    91             variants)))
    92 
    93 (define-macro concrete-case
    94   (macro-rules (else)
    95     ((_ (xpr type?) . clauses)
    96      (where ((conjoin (list-of? list?)
    97                       (disjoin (bindable? ((Constr . args) . xprs))
    98                                (bindable? (else . xprs))))
    99              clauses)
    100             (not (null? clauses)))
    101      `(let ((tmp ,xpr))
    102         (if (##core#check (,type? tmp))
    103           (let ((tag (##sys#slot tmp 1)))
    104             (cond ,@(map (lambda (clause)
    105                            (bind-case clause
    106                              (((variantname . variantargs) xpr . xprs)
    107                               `((eq? tag ',variantname)
    108                                 (invoke
    109                                   ',variantname tmp
    110                                   ,(length variantargs)
    111                                   (lambda ,variantargs
    112                                     ,xpr ,@xprs))))
    113                              ((else xpr . xprs)
    114                               `(else (let () ,xpr ,@xprs)))
    115                              ))
    116                          clauses)))
    117           (##sys#signal-hook #:type-error
    118              "typecheck didn't pass in concrete-case"
    119              `(,',type?  ,tmp)))))))
     60  (import scheme chicken
     61          (only data-structures conjoin list-of?))
     62  (import-for-syntax (only chicken assert))
     63
     64(define-syntax define-concrete-type
     65  (ir-macro-transformer
     66    (lambda (form inject compare?)
     67      (let ((TYPE (cadr form))
     68            (type? (caddr form))
     69            (variants (cdddr form)))
     70        (assert (pair? variants))
     71        (assert ((list-of? pair?) variants))
     72        (assert ((list-of? symbol?) (map car variants)))
     73        `(begin
     74           (define (,type? form)
     75             (##sys#structure? form ',TYPE))
     76           ,@(map (lambda (variant)
     77                    (let ((variantname (car variant))
     78                          (checkedargs (cdr variant)))
     79                      (let ((variantargs (map car checkedargs))
     80                            (variantpreds (map cdr checkedargs)))
     81                        `(define (,variantname ,@variantargs)
     82                           (##sys#make-structure
     83                            ',TYPE ',variantname
     84                            ,@(map (lambda (name pred)
     85                                     `(if (##core#check (,pred ,name))
     86                                        ,name
     87                                        (##sys#signal-hook
     88                                         #:type-error
     89                                         "bad argument type to variant constructor"
     90                                         ,name ',variantname ',name)))
     91                                   variantargs
     92                                   (map (lambda (preds)
     93                                          `(conjoin ,@preds))
     94                                                    variantpreds)))))))
     95                  variants))))))
     96
     97(define-syntax concrete-case
     98  (ir-macro-transformer
     99    (lambda (form inject compare?)
     100      (let ((pair (cadr form))
     101            (clauses (cddr form)))
     102        (assert (pair? clauses))
     103        (assert ((list-of? pair?) clauses))
     104        (assert ((list-of? pair?) (map cdr clauses)))
     105        (assert ((list-of? (lambda (x)
     106                             (or (compare? x 'else)
     107                                 (and (pair? x)
     108                                      (symbol? (car x))))))
     109                 (map car clauses)))
     110        (let ((xpr (car pair))
     111              (type? (cadr pair)))
     112          `(let ((tmp ,xpr))
     113             (if (##core#check (,type? tmp))
     114               (let ((tag (##sys#slot tmp 1)))
     115                 (cond ,@(map (lambda (clause)
     116                                (let ((first (car clause))
     117                                      (xpr (cadr clause))
     118                                      (xprs (cddr clause)))
     119                                  (if (pair? first)
     120                                    (let ((variantname (car first))
     121                                          (variantargs (cdr first)))
     122                                      `((eq? tag ',variantname)
     123                                        (invoke
     124                                          ',variantname tmp
     125                                          ,(length variantargs)
     126                                          (lambda ,variantargs
     127                                            ,xpr ,@xprs))))
     128                                    `(else (let () ,xpr ,@xprs)))))
     129                              clauses)))
     130               (##sys#signal-hook #:type-error
     131                "typecheck didn't pass in concrete-case"
     132                `(,',type?  ,tmp)))))))))
    120133
    121134(define (invoke name block count proc)
     
    132145                     (rec (fx+ i 1)))))))))
    133146
    134 (define-macro define-abstract-type
    135   (macro-rules (with printer reader)
    136     ((_ TYPE type?
    137         (variant . variants)
    138         (with routine . routines)
    139         (printer . printers)
    140         (reader . readers))
    141      (where ((conjoin (list-of? list?) (o not null?)) variants))
    142      (let ((variants (cons variant variants))
    143            (routines (cons routine routines)))
    144        (let ((names (map caar routines))
    145              (args (map cdar routines))
    146              (bodies (map cdr routines)))
    147          `(define-values (,type?  ,@names)
    148             (letrec ,(map (lambda (n) `(,n #f)) names)
    149               (define-concrete-type ,TYPE ,type?
    150                                     ,variants)
    151               ,@(map (lambda (n a b) `(set! ,n (lambda ,a ,@b)))
    152                      names args bodies)
    153               ,(if (null? printers)
    154                  #f
    155                  `(define-record-printer ,TYPE ,(car printers)))
    156               ,(if (null? readers)
    157                  #f
    158                  `(define-reader-ctor ',TYPE ,(car readers)))
    159               (values ,type? ,@names))))))
    160     ((_ TYPE type?
    161         (variant . variants)
    162         (with . routines)
    163         (printer . printers))
    164      `(define-abstract-type ,TYPE ,type?
    165         (,variant ,@variants)
    166         (with ,@routines)
    167         (printer ,@printers)
    168         (reader)))
    169     ((_ TYPE type?
    170         (variant . variants)
    171         (with . routines))
    172      `(define-abstract-type ,TYPE ,type?
    173         (,variant ,@variants)
    174         (with ,@routines)
    175         (printer)
    176         (reader)))))
     147(define-syntax define-abstract-type
     148  (ir-macro-transformer
     149    (lambda (form inject compare?)
     150      (let ((TYPE (cadr form))
     151            (type? (caddr form))
     152            (rest (reverse (cdddr form))))
     153        (cond
     154          ((compare? (caar rest) 'reader)
     155           (define variants (reverse (list-tail rest 3)))
     156           (define routines (cdr (list-ref rest 2)))
     157           (define printer (cadr (list-ref rest 1)))
     158           (define reader (cadr (list-ref rest 0))))
     159          ((compare? (caar rest) 'printer)
     160           (define variants (reverse (list-tail rest 2)))
     161           (define routines (cdr (list-ref rest 1)))
     162           (define printer (cadr (list-ref rest 0)))
     163           (define reader #f))
     164          ((compare? (caar rest) 'with)
     165           (define variants (reverse (list-tail rest 1)))
     166           (define routines (cdr (list-ref rest 0)))
     167           (define printer #f)
     168           (define reader #f))
     169          (else
     170            (error 'define-abstract-type "syntax error")))
     171        (assert (pair? variants))
     172        (assert ((list-of? pair?) variants))
     173        (assert (pair? routines))
     174        (assert ((list-of? pair?) routines))
     175        (let ((names (map caar routines))
     176              (args (map cdar routines))
     177              (bodies (map cdr routines)))
     178          `(define-values (,type?  ,@names)
     179             (letrec ,(map (lambda (n) `(,n #f)) names)
     180               (define-concrete-type ,TYPE ,type? ,@variants)
     181               ,@(map (lambda (n a b) `(set! ,n (lambda ,a ,@b)))
     182                      names args bodies)
     183               ,(if printer
     184                  `(define-record-printer ,TYPE ,printer))
     185               ,(if reader
     186                  `(define-reader-ctor ',TYPE ,reader))
     187               (values ,type? ,@names))))))))
    177188
    178189;;; (define-object-type CHILD child? make-child
     
    181192;;;   ((X (x x? ...) ...) xpr . xprs)        ; new messages
    182193;;;   ....)
    183 ;;; -------------------------------------------------
    184 (define-macro define-object-type
    185   (macro-rules Types Invariant Info Ancestors (override)
    186     ((_ CHILD child? make-child
    187         ((parent parent?) . xss)
    188         (override . obody)
    189         . body)
    190      (where ((list-of? list?) xss)
    191             ((list-of? (bindable? ((A . as) apr . aprs)))
    192              obody)
    193             (not (null? body))
    194             ((list-of? (bindable? ((X . xs) xpr . xprs)))
    195              body)
    196             )
    197      (let ((xs (map car xss))
    198            (xs? (map (lambda (ps) `(conjoin ,@ps)) (map cdr xss)))
     194;;; -------------------------------------------
     195(define-syntax define-object-type
     196  (ir-macro-transformer
     197    (lambda (form inject compare?)
     198      (let ((CHILD (list-ref form 1))
     199            (child? (list-ref form 2))
     200            (make-child (list-ref form 3))
     201            (parent-clause (list-ref form 4))
     202            (override-clause (list-ref form 5))
     203            (body (list-tail form 6)))
     204        (assert (pair? parent-clause))
     205        (assert (pair? (car parent-clause)))
     206        (assert (pair? override-clause))
     207        (assert (compare? (car override-clause) 'override))
     208        (assert (pair? body))
     209        (assert ((list-of? pair?) (map car body)))
     210        (assert ((list-of? symbol?) (map caar body)))
     211        (assert ((list-of? pair?) (map cdr body)))
     212        (let ((parent-pair (car parent-clause))
     213              (xss (cdr parent-clause))
     214              (obody (cdr override-clause)))
     215          (pair? xss)
     216          ((list-of? pair?) xss)
     217          (assert ((list-of? pair?) (map car obody)))
     218          (assert ((list-of? symbol?) (map caar obody)))
     219          (assert ((list-of? pair?) (map cdr obody)))
     220     (let ((parent (car parent-pair))
     221           (parent? (cadr parent-pair))
     222           (xs (map car xss))
     223           (xs? (map (lambda (ps) `(conjoin ,@ps))
     224                     (map cdr xss)))
    199225           (messages (map car body))
    200226           (omessages (map car obody))
     
    203229                             as
    204230                             (map car as)))))
    205        ;(xpr:val xs xs? messages)
    206231       (let ((message-names (append (map car omessages)
    207232                                    (map car messages)))
    208233             (arg-names
    209234               (append (map extract-args (map cdr omessages))
    210                        (map extract-args (map cdr messages)))))
    211          ;(xpr:val message-names arg-names)
     235                       (map extract-args (map cdr messages))))
     236             (Types (inject 'Types))
     237             (Invariant (inject 'Invariant))
     238             (Info (inject 'Info))
     239             (Ancestors (inject 'Ancestors)))
    212240         `(define-values (,make-child ,child? ,@message-names)
    213241            (let ((type (gensym ',CHILD)))
     
    256284                         ((exn) #f))))
    257285                ;; messages
    258                 ,@message-names))))))))
     286                ,@message-names))))))))))
    259287
    260288;;; base object
  • release/4/datatypes/tags/1.3/datatypes.setup

    r32516 r33052  
    11;;;; datatypes.setup -*- Scheme -*-
    22
    3 (compile -s -O3 -d1 datatypes.scm -j datatypes)
     3(compile -s -O3 -d1 datatypes.scm -J)
    44(compile -s -O3 -d0 datatypes.import.scm)
    55
     
    77 'datatypes
    88 `("datatypes.so" "datatypes.import.so")
    9  `((version 1.2)))
     9 `((version 1.3)))
    1010
  • release/4/datatypes/tags/1.3/tests/run.scm

    r32516 r33052  
    22(import datatypes cells simple-tests)
    33
    4 (define-test (datatypes?)
     4(define-test (concrete-types?)
    55  (check
    6 
    7     "Concrete types"
     6    "Immutable lists as concrete types"
    87    (define-concrete-type LIST List?
    98      (List-null)
     
    5049    (= 0 (chain-item 1 (integers 0)))
    5150    (= 25 (chain-item 26 (integers 0)))
     51    ))
    5252
    53     "Abstract types"
     53(define-test (abstract-types?)
     54  (check
     55    "Points as abstract types"
    5456    (define-abstract-type POINT point?
    55       (Point (x number?) (y number?))
     57      (Point (x number?) (y number?)) ; hidden
    5658      (with
    57         ((point x y) (Point x y))
     59        ((make-point x y) (Point x y)) ; exported
    5860        ((point-x pt)
    5961         (concrete-case (pt point?)
     
    6971          (display (point-y pt) out)
    7072          (display ")\n" out)))
    71       (reader Point))
    72     (define pt (point 1 2))
     73      (reader Point)
     74      )
     75
     76    (define pt (make-point 1 2))
    7377    (print pt)
    7478    (= (point-x pt) 1)
    7579    (point? pt)
    7680    (not (point? Lst))
    77 ))
     81    ))
    7882
    79 (define-test (objects?)
     83(define-test (object-types?)
    8084  (check
    81     (define-object-type POINT point? make-point
     85    (define-object-type COUPLE couple? make-couple
    8286      ((parent object?) (x (cell-of? number?)) (y (cell-of? number?)))
    8387       (override)
    8488       ; no overrides except those of base object
    85       ;; new messages with hanlers
    86       ((X) (cell-ref x))
    87       ((Y) (cell-ref y))
    88       ((X-set! (arg number?))
     89      ;; new messages with handlers
     90      ((First) (cell-ref x))
     91      ((Second) (cell-ref y))
     92      ((First-set! (arg number?))
    8993       (set! (cell-ref x) arg))
    90       ((Y-set! (arg number?))
     94      ((Second-set! (arg number?))
    9195       (set! (cell-ref y) arg))
    9296      )
    93     (define-object-type POINT_3D point-3d? make-point-3d
    94       ((parent point?) (z (cell-of? number?)))
    95       (override ((X) (* 2 (parent (X))))
     97
     98    (define-object-type TRIPLE triple? make-triple
     99      ((parent couple?) (z (cell-of? number?)))
     100      (override ((First) (* 2 (parent (First))))
    96101                ;; preconditions checked in parent
    97102                ;; hence no predicates in args
    98                 ((X-set! arg)
    99                  (parent (X-set! (* 2 arg)))))
    100       ((Z) (cell-ref z))
    101       ((Z-set! (arg number?))
     103                ((First-set! arg)
     104                 (parent (First-set! (* 2 arg)))))
     105      ((Third) (cell-ref z))
     106      ((Third-set! (arg number?))
    102107       (set! (cell-ref z) arg))
    103108      )
     109
     110    (define-object-type FOO foo? make-foo
     111      ((parent object?) (x (cell-of? integer?)))
     112       (override)
     113       ; no overrides except those of base object
     114      ;; new messages with handlers
     115      ((First) (cell-ref x))
     116      ;; ueberschreibt die Argument-Typen von cpl und trp
     117      ((First-set! (arg integer?))
     118       (set! (cell-ref x) arg))
     119      )
     120
    104121    (define obj (make-base-object))
    105122    (object? obj)
     
    107124    (obj (Invariant))
    108125    (obj (Info))
    109     (define p2
    110       (make-point obj (cell 1) (cell 2)))
    111     (point? p2)
    112     (object? p2)
    113     (not (point? X))
    114     (p2 (Types))
    115     (p2 (Info))
    116     (p2 (Invariant))
    117     (p2 (Ancestors))
    118     (= (p2 (X)) 1)
    119     (= (p2 (Y)) 2)
    120     (p2 (X-set! 10))
    121     (p2 (Y-set! 20))
    122     (= (p2 (X)) 10)
    123     (= (p2 (Y)) 20)
    124     (define p3 (make-point-3d p2 (cell 3)))
    125     (p3 (Ancestors))
    126     (p3 (Info))
    127     (= (p3 (Z)) 3)
    128     (p3 (Z-set! 30))
    129     (= (p3 (Z)) 30)
    130     (= (p3 (X)) 20)
    131     (= (p3 (Y)) 20)
    132     (p3 (Y-set! 2))
    133     (= (p3 (Y)) 2)
    134     (p3 (X-set! 25))
    135     (= (p3 (X)) 100)
    136     (point-3d? p3)
    137     (not (point-3d? p2))
    138     (point? p3)
    139     (object? p3)
     126
     127    (define foo (make-foo obj (cell 101)))
     128    (= (foo (First)) 101)
     129    (foo (First-set! 202))
     130    (= (foo (First)) 202)
     131   
     132    (define cpl
     133      (make-couple obj (cell 1) (cell 2)))
     134    (couple? cpl)
     135    (object? cpl)
     136    (not (couple? First))
     137    (cpl (Types))
     138    (cpl (Info))
     139    (cpl (Invariant))
     140    (cpl (Ancestors))
     141    (= (cpl (First)) 1)
     142    (= (cpl (Second)) 2)
     143    (cpl (First-set! 10))
     144    (cpl (Second-set! 20))
     145    (= (cpl (First)) 10)
     146    (= (cpl (Second)) 20)
     147   
     148    (define trp (make-triple cpl (cell 3)))
     149    (trp (Ancestors))
     150    (trp (Info))
     151    (= (trp (Third)) 3)
     152    (trp (Third-set! 30))
     153    (= (trp (Third)) 30)
     154    (= (trp (First)) 20)
     155    (= (trp (Second)) 20)
     156    (trp (Second-set! 2))
     157    (= (trp (Second)) 2)
     158    (trp (First-set! 25))
     159    (= (trp (First)) 100)
     160    (triple? trp)
     161    (not (triple? cpl))
     162    (couple? trp)
     163    (object? trp)
    140164    ))
    141165
    142 
    143166(compound-test (DATATYPES)
    144   (datatypes?)
    145   (objects?)
     167  (concrete-types?)
     168  (abstract-types?)
     169  (object-types?)
    146170  )
    147171
  • release/4/datatypes/trunk/datatypes.meta

    r32516 r33052  
    22
    33((synopsis
    4    "Creating concrete and abstract types as in ML")
     4   "Creating concrete-, abstract- and object-types")
    55 (category lang-exts)
    66 (license "BSD")
    7  (depends bindings)
    87 (test-depends simple-tests cells)
    98 (author "[[Juergen Lorenz]]")
  • release/4/datatypes/trunk/datatypes.scm

    r32516 r33052  
    33ju (at) jugilo (dot) de
    44
    5 Copyright (c) 2015, Juergen Lorenz
     5Copyright (c) 2015-2016, Juergen Lorenz
    66All rights reserved.
    77
     
    4646; concrete-types.
    4747
    48 (require-library bindings)
    49 
    5048(module datatypes (define-concrete-type
    5149                  (concrete-case invoke)
     
    6058                  datatypes)
    6159
    62   (import scheme chicken bindings
    63           (only data-structures conjoin disjoin o))
    64   (import-for-syntax (only bindings macro-rules bindable? bind-case))
    65 
    66 (define-macro (define-concrete-type TYPE type? . variants)
    67   (where ((list-of? list?) variants)
    68          (not (null? variants))
    69          ((list-of? symbol?) (map car variants))
    70          ((list-of? list?) (map cdr variants)))
    71   `(begin
    72      (define (,type? form) (##sys#structure? form ',TYPE))
    73      ,@(map (lambda (variant)
    74               (bind-case variant
    75                 ((variantname . checkedargs)
    76                  (let ((variantargs (map car checkedargs))
    77                        (variantpreds (map cdr checkedargs)))
    78                    `(define (,variantname ,@variantargs)
    79                       (##sys#make-structure
    80                        ',TYPE ',variantname
    81                        ,@(map (lambda (name pred)
    82                                 `(if (##core#check (,pred ,name))
    83                                    ,name
    84                                    (##sys#signal-hook
    85                                     #:type-error
    86                                     "bad argument type to variant constructor"
    87                                     ,name ',variantname ',name)))
    88                               variantargs (map (lambda (preds)
    89                                                  `(conjoin ,@preds))
    90                                                variantpreds))))))))
    91             variants)))
    92 
    93 (define-macro concrete-case
    94   (macro-rules (else)
    95     ((_ (xpr type?) . clauses)
    96      (where ((conjoin (list-of? list?)
    97                       (disjoin (bindable? ((Constr . args) . xprs))
    98                                (bindable? (else . xprs))))
    99              clauses)
    100             (not (null? clauses)))
    101      `(let ((tmp ,xpr))
    102         (if (##core#check (,type? tmp))
    103           (let ((tag (##sys#slot tmp 1)))
    104             (cond ,@(map (lambda (clause)
    105                            (bind-case clause
    106                              (((variantname . variantargs) xpr . xprs)
    107                               `((eq? tag ',variantname)
    108                                 (invoke
    109                                   ',variantname tmp
    110                                   ,(length variantargs)
    111                                   (lambda ,variantargs
    112                                     ,xpr ,@xprs))))
    113                              ((else xpr . xprs)
    114                               `(else (let () ,xpr ,@xprs)))
    115                              ))
    116                          clauses)))
    117           (##sys#signal-hook #:type-error
    118              "typecheck didn't pass in concrete-case"
    119              `(,',type?  ,tmp)))))))
     60  (import scheme chicken
     61          (only data-structures conjoin list-of?))
     62  (import-for-syntax (only chicken assert))
     63
     64(define-syntax define-concrete-type
     65  (ir-macro-transformer
     66    (lambda (form inject compare?)
     67      (let ((TYPE (cadr form))
     68            (type? (caddr form))
     69            (variants (cdddr form)))
     70        (assert (pair? variants))
     71        (assert ((list-of? pair?) variants))
     72        (assert ((list-of? symbol?) (map car variants)))
     73        `(begin
     74           (define (,type? form)
     75             (##sys#structure? form ',TYPE))
     76           ,@(map (lambda (variant)
     77                    (let ((variantname (car variant))
     78                          (checkedargs (cdr variant)))
     79                      (let ((variantargs (map car checkedargs))
     80                            (variantpreds (map cdr checkedargs)))
     81                        `(define (,variantname ,@variantargs)
     82                           (##sys#make-structure
     83                            ',TYPE ',variantname
     84                            ,@(map (lambda (name pred)
     85                                     `(if (##core#check (,pred ,name))
     86                                        ,name
     87                                        (##sys#signal-hook
     88                                         #:type-error
     89                                         "bad argument type to variant constructor"
     90                                         ,name ',variantname ',name)))
     91                                   variantargs
     92                                   (map (lambda (preds)
     93                                          `(conjoin ,@preds))
     94                                                    variantpreds)))))))
     95                  variants))))))
     96
     97(define-syntax concrete-case
     98  (ir-macro-transformer
     99    (lambda (form inject compare?)
     100      (let ((pair (cadr form))
     101            (clauses (cddr form)))
     102        (assert (pair? clauses))
     103        (assert ((list-of? pair?) clauses))
     104        (assert ((list-of? pair?) (map cdr clauses)))
     105        (assert ((list-of? (lambda (x)
     106                             (or (compare? x 'else)
     107                                 (and (pair? x)
     108                                      (symbol? (car x))))))
     109                 (map car clauses)))
     110        (let ((xpr (car pair))
     111              (type? (cadr pair)))
     112          `(let ((tmp ,xpr))
     113             (if (##core#check (,type? tmp))
     114               (let ((tag (##sys#slot tmp 1)))
     115                 (cond ,@(map (lambda (clause)
     116                                (let ((first (car clause))
     117                                      (xpr (cadr clause))
     118                                      (xprs (cddr clause)))
     119                                  (if (pair? first)
     120                                    (let ((variantname (car first))
     121                                          (variantargs (cdr first)))
     122                                      `((eq? tag ',variantname)
     123                                        (invoke
     124                                          ',variantname tmp
     125                                          ,(length variantargs)
     126                                          (lambda ,variantargs
     127                                            ,xpr ,@xprs))))
     128                                    `(else (let () ,xpr ,@xprs)))))
     129                              clauses)))
     130               (##sys#signal-hook #:type-error
     131                "typecheck didn't pass in concrete-case"
     132                `(,',type?  ,tmp)))))))))
    120133
    121134(define (invoke name block count proc)
     
    132145                     (rec (fx+ i 1)))))))))
    133146
    134 (define-macro define-abstract-type
    135   (macro-rules (with printer reader)
    136     ((_ TYPE type?
    137         (variant . variants)
    138         (with routine . routines)
    139         (printer . printers)
    140         (reader . readers))
    141      (where ((conjoin (list-of? list?) (o not null?)) variants))
    142      (let ((variants (cons variant variants))
    143            (routines (cons routine routines)))
    144        (let ((names (map caar routines))
    145              (args (map cdar routines))
    146              (bodies (map cdr routines)))
    147          `(define-values (,type?  ,@names)
    148             (letrec ,(map (lambda (n) `(,n #f)) names)
    149               (define-concrete-type ,TYPE ,type?
    150                                     ,variants)
    151               ,@(map (lambda (n a b) `(set! ,n (lambda ,a ,@b)))
    152                      names args bodies)
    153               ,(if (null? printers)
    154                  #f
    155                  `(define-record-printer ,TYPE ,(car printers)))
    156               ,(if (null? readers)
    157                  #f
    158                  `(define-reader-ctor ',TYPE ,(car readers)))
    159               (values ,type? ,@names))))))
    160     ((_ TYPE type?
    161         (variant . variants)
    162         (with . routines)
    163         (printer . printers))
    164      `(define-abstract-type ,TYPE ,type?
    165         (,variant ,@variants)
    166         (with ,@routines)
    167         (printer ,@printers)
    168         (reader)))
    169     ((_ TYPE type?
    170         (variant . variants)
    171         (with . routines))
    172      `(define-abstract-type ,TYPE ,type?
    173         (,variant ,@variants)
    174         (with ,@routines)
    175         (printer)
    176         (reader)))))
     147(define-syntax define-abstract-type
     148  (ir-macro-transformer
     149    (lambda (form inject compare?)
     150      (let ((TYPE (cadr form))
     151            (type? (caddr form))
     152            (rest (reverse (cdddr form))))
     153        (cond
     154          ((compare? (caar rest) 'reader)
     155           (define variants (reverse (list-tail rest 3)))
     156           (define routines (cdr (list-ref rest 2)))
     157           (define printer (cadr (list-ref rest 1)))
     158           (define reader (cadr (list-ref rest 0))))
     159          ((compare? (caar rest) 'printer)
     160           (define variants (reverse (list-tail rest 2)))
     161           (define routines (cdr (list-ref rest 1)))
     162           (define printer (cadr (list-ref rest 0)))
     163           (define reader #f))
     164          ((compare? (caar rest) 'with)
     165           (define variants (reverse (list-tail rest 1)))
     166           (define routines (cdr (list-ref rest 0)))
     167           (define printer #f)
     168           (define reader #f))
     169          (else
     170            (error 'define-abstract-type "syntax error")))
     171        (assert (pair? variants))
     172        (assert ((list-of? pair?) variants))
     173        (assert (pair? routines))
     174        (assert ((list-of? pair?) routines))
     175        (let ((names (map caar routines))
     176              (args (map cdar routines))
     177              (bodies (map cdr routines)))
     178          `(define-values (,type?  ,@names)
     179             (letrec ,(map (lambda (n) `(,n #f)) names)
     180               (define-concrete-type ,TYPE ,type? ,@variants)
     181               ,@(map (lambda (n a b) `(set! ,n (lambda ,a ,@b)))
     182                      names args bodies)
     183               ,(if printer
     184                  `(define-record-printer ,TYPE ,printer))
     185               ,(if reader
     186                  `(define-reader-ctor ',TYPE ,reader))
     187               (values ,type? ,@names))))))))
    177188
    178189;;; (define-object-type CHILD child? make-child
     
    181192;;;   ((X (x x? ...) ...) xpr . xprs)        ; new messages
    182193;;;   ....)
    183 ;;; -------------------------------------------------
    184 (define-macro define-object-type
    185   (macro-rules Types Invariant Info Ancestors (override)
    186     ((_ CHILD child? make-child
    187         ((parent parent?) . xss)
    188         (override . obody)
    189         . body)
    190      (where ((list-of? list?) xss)
    191             ((list-of? (bindable? ((A . as) apr . aprs)))
    192              obody)
    193             (not (null? body))
    194             ((list-of? (bindable? ((X . xs) xpr . xprs)))
    195              body)
    196             )
    197      (let ((xs (map car xss))
    198            (xs? (map (lambda (ps) `(conjoin ,@ps)) (map cdr xss)))
     194;;; -------------------------------------------
     195(define-syntax define-object-type
     196  (ir-macro-transformer
     197    (lambda (form inject compare?)
     198      (let ((CHILD (list-ref form 1))
     199            (child? (list-ref form 2))
     200            (make-child (list-ref form 3))
     201            (parent-clause (list-ref form 4))
     202            (override-clause (list-ref form 5))
     203            (body (list-tail form 6)))
     204        (assert (pair? parent-clause))
     205        (assert (pair? (car parent-clause)))
     206        (assert (pair? override-clause))
     207        (assert (compare? (car override-clause) 'override))
     208        (assert (pair? body))
     209        (assert ((list-of? pair?) (map car body)))
     210        (assert ((list-of? symbol?) (map caar body)))
     211        (assert ((list-of? pair?) (map cdr body)))
     212        (let ((parent-pair (car parent-clause))
     213              (xss (cdr parent-clause))
     214              (obody (cdr override-clause)))
     215          (pair? xss)
     216          ((list-of? pair?) xss)
     217          (assert ((list-of? pair?) (map car obody)))
     218          (assert ((list-of? symbol?) (map caar obody)))
     219          (assert ((list-of? pair?) (map cdr obody)))
     220     (let ((parent (car parent-pair))
     221           (parent? (cadr parent-pair))
     222           (xs (map car xss))
     223           (xs? (map (lambda (ps) `(conjoin ,@ps))
     224                     (map cdr xss)))
    199225           (messages (map car body))
    200226           (omessages (map car obody))
     
    203229                             as
    204230                             (map car as)))))
    205        ;(xpr:val xs xs? messages)
    206231       (let ((message-names (append (map car omessages)
    207232                                    (map car messages)))
    208233             (arg-names
    209234               (append (map extract-args (map cdr omessages))
    210                        (map extract-args (map cdr messages)))))
    211          ;(xpr:val message-names arg-names)
     235                       (map extract-args (map cdr messages))))
     236             (Types (inject 'Types))
     237             (Invariant (inject 'Invariant))
     238             (Info (inject 'Info))
     239             (Ancestors (inject 'Ancestors)))
    212240         `(define-values (,make-child ,child? ,@message-names)
    213241            (let ((type (gensym ',CHILD)))
     
    256284                         ((exn) #f))))
    257285                ;; messages
    258                 ,@message-names))))))))
     286                ,@message-names))))))))))
    259287
    260288;;; base object
  • release/4/datatypes/trunk/datatypes.setup

    r32516 r33052  
    11;;;; datatypes.setup -*- Scheme -*-
    22
    3 (compile -s -O3 -d1 datatypes.scm -j datatypes)
     3(compile -s -O3 -d1 datatypes.scm -J)
    44(compile -s -O3 -d0 datatypes.import.scm)
    55
     
    77 'datatypes
    88 `("datatypes.so" "datatypes.import.so")
    9  `((version 1.2)))
     9 `((version 1.3)))
    1010
  • release/4/datatypes/trunk/tests/run.scm

    r32516 r33052  
    22(import datatypes cells simple-tests)
    33
    4 (define-test (datatypes?)
     4(define-test (concrete-types?)
    55  (check
    6 
    7     "Concrete types"
     6    "Immutable lists as concrete types"
    87    (define-concrete-type LIST List?
    98      (List-null)
     
    5049    (= 0 (chain-item 1 (integers 0)))
    5150    (= 25 (chain-item 26 (integers 0)))
     51    ))
    5252
    53     "Abstract types"
     53(define-test (abstract-types?)
     54  (check
     55    "Points as abstract types"
    5456    (define-abstract-type POINT point?
    55       (Point (x number?) (y number?))
     57      (Point (x number?) (y number?)) ; hidden
    5658      (with
    57         ((point x y) (Point x y))
     59        ((make-point x y) (Point x y)) ; exported
    5860        ((point-x pt)
    5961         (concrete-case (pt point?)
     
    6971          (display (point-y pt) out)
    7072          (display ")\n" out)))
    71       (reader Point))
    72     (define pt (point 1 2))
     73      (reader Point)
     74      )
     75
     76    (define pt (make-point 1 2))
    7377    (print pt)
    7478    (= (point-x pt) 1)
    7579    (point? pt)
    7680    (not (point? Lst))
    77 ))
     81    ))
    7882
    79 (define-test (objects?)
     83(define-test (object-types?)
    8084  (check
    81     (define-object-type POINT point? make-point
     85    (define-object-type COUPLE couple? make-couple
    8286      ((parent object?) (x (cell-of? number?)) (y (cell-of? number?)))
    8387       (override)
    8488       ; no overrides except those of base object
    85       ;; new messages with hanlers
    86       ((X) (cell-ref x))
    87       ((Y) (cell-ref y))
    88       ((X-set! (arg number?))
     89      ;; new messages with handlers
     90      ((First) (cell-ref x))
     91      ((Second) (cell-ref y))
     92      ((First-set! (arg number?))
    8993       (set! (cell-ref x) arg))
    90       ((Y-set! (arg number?))
     94      ((Second-set! (arg number?))
    9195       (set! (cell-ref y) arg))
    9296      )
    93     (define-object-type POINT_3D point-3d? make-point-3d
    94       ((parent point?) (z (cell-of? number?)))
    95       (override ((X) (* 2 (parent (X))))
     97
     98    (define-object-type TRIPLE triple? make-triple
     99      ((parent couple?) (z (cell-of? number?)))
     100      (override ((First) (* 2 (parent (First))))
    96101                ;; preconditions checked in parent
    97102                ;; hence no predicates in args
    98                 ((X-set! arg)
    99                  (parent (X-set! (* 2 arg)))))
    100       ((Z) (cell-ref z))
    101       ((Z-set! (arg number?))
     103                ((First-set! arg)
     104                 (parent (First-set! (* 2 arg)))))
     105      ((Third) (cell-ref z))
     106      ((Third-set! (arg number?))
    102107       (set! (cell-ref z) arg))
    103108      )
     109
     110    (define-object-type FOO foo? make-foo
     111      ((parent object?) (x (cell-of? integer?)))
     112       (override)
     113       ; no overrides except those of base object
     114      ;; new messages with handlers
     115      ((First) (cell-ref x))
     116      ;; ueberschreibt die Argument-Typen von cpl und trp
     117      ((First-set! (arg integer?))
     118       (set! (cell-ref x) arg))
     119      )
     120
    104121    (define obj (make-base-object))
    105122    (object? obj)
     
    107124    (obj (Invariant))
    108125    (obj (Info))
    109     (define p2
    110       (make-point obj (cell 1) (cell 2)))
    111     (point? p2)
    112     (object? p2)
    113     (not (point? X))
    114     (p2 (Types))
    115     (p2 (Info))
    116     (p2 (Invariant))
    117     (p2 (Ancestors))
    118     (= (p2 (X)) 1)
    119     (= (p2 (Y)) 2)
    120     (p2 (X-set! 10))
    121     (p2 (Y-set! 20))
    122     (= (p2 (X)) 10)
    123     (= (p2 (Y)) 20)
    124     (define p3 (make-point-3d p2 (cell 3)))
    125     (p3 (Ancestors))
    126     (p3 (Info))
    127     (= (p3 (Z)) 3)
    128     (p3 (Z-set! 30))
    129     (= (p3 (Z)) 30)
    130     (= (p3 (X)) 20)
    131     (= (p3 (Y)) 20)
    132     (p3 (Y-set! 2))
    133     (= (p3 (Y)) 2)
    134     (p3 (X-set! 25))
    135     (= (p3 (X)) 100)
    136     (point-3d? p3)
    137     (not (point-3d? p2))
    138     (point? p3)
    139     (object? p3)
     126
     127    (define foo (make-foo obj (cell 101)))
     128    (= (foo (First)) 101)
     129    (foo (First-set! 202))
     130    (= (foo (First)) 202)
     131   
     132    (define cpl
     133      (make-couple obj (cell 1) (cell 2)))
     134    (couple? cpl)
     135    (object? cpl)
     136    (not (couple? First))
     137    (cpl (Types))
     138    (cpl (Info))
     139    (cpl (Invariant))
     140    (cpl (Ancestors))
     141    (= (cpl (First)) 1)
     142    (= (cpl (Second)) 2)
     143    (cpl (First-set! 10))
     144    (cpl (Second-set! 20))
     145    (= (cpl (First)) 10)
     146    (= (cpl (Second)) 20)
     147   
     148    (define trp (make-triple cpl (cell 3)))
     149    (trp (Ancestors))
     150    (trp (Info))
     151    (= (trp (Third)) 3)
     152    (trp (Third-set! 30))
     153    (= (trp (Third)) 30)
     154    (= (trp (First)) 20)
     155    (= (trp (Second)) 20)
     156    (trp (Second-set! 2))
     157    (= (trp (Second)) 2)
     158    (trp (First-set! 25))
     159    (= (trp (First)) 100)
     160    (triple? trp)
     161    (not (triple? cpl))
     162    (couple? trp)
     163    (object? trp)
    140164    ))
    141165
    142 
    143166(compound-test (DATATYPES)
    144   (datatypes?)
    145   (objects?)
     167  (concrete-types?)
     168  (abstract-types?)
     169  (object-types?)
    146170  )
    147171
Note: See TracChangeset for help on using the changeset viewer.