Changeset 11130 in project


Ignore:
Timestamp:
07/01/08 09:42:11 (12 years ago)
Author:
felix winkelmann
Message:

ported to highlevel macros

Location:
release/4/datatype
Files:
1 added
1 deleted
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/datatype/datatype.meta

    r8995 r11130  
    11;;; datatype.meta -*- Hen -*-
    22
    3 ((date "2003-04-14")
    4  (egg "datatype.egg")
     3((egg "datatype.egg")
    54 (synopsis
    65   "A facility for creating and deconstructing variant records (from EOPL)")
  • release/4/datatype/datatype.scm

    r1 r11130  
    11;;;; datatype.scm - Variant record types from "Essentials of Programming Languages" - felix
    22;
    3 ; Copyright (c) 2000-2003, Felix L. Winkelmann
     3; Copyright (c) 2008, The CHICKEN Team
     4; Copyright (c) 2000-2007, Felix L. Winkelmann
    45; All rights reserved.
    56;
     
    2324; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    2425; POSSIBILITY OF SUCH DAMAGE.
    25 ;
    26 ; Send bugs, suggestions and ideas to:
    27 ;
    28 ; felix@call-with-current-continuation.org
    29 ;
    30 ; Felix L. Winkelmann
    31 ; Steinweg 1A
    32 ; 37130 Gleichen, OT Weissenborn
    33 ; Germany
    3426
    3527
    36 (define-macro (define-datatype typename x . rest)
    37   (##sys#check-syntax 'define-datatype typename 'symbol)
    38   `(begin
    39      ,@(if (symbol? x)
    40            `((define (,x x) (##sys#structure? x ',typename)))
    41            '() )
    42      ,@(map (lambda (variant)
    43               (##sys#check-syntax 'define-datatype variant '(symbol . #((symbol _) 0)))
    44               (let ([variantname (car variant)]
    45                     [fieldnames (map car (cdr variant))]
    46                     [fieldpreds (map cadr (cdr variant))] )
    47                 `(define (,(car variant) ,@fieldnames)
    48                    (##sys#make-structure
    49                     ',typename ',variantname
    50                     ,@(map (lambda (name pred)
    51                              `(if (##core#check (,pred ,name))
    52                                   ,name
    53                                   (##sys#signal-hook
    54                                    #:type-error
    55                                    (##core#immutable '"bad argument type to variant constructor")
    56                                    ,name ',variantname ',name) ) )
    57                            fieldnames fieldpreds) ) ) ) )
    58             (if (symbol? x)
    59                 rest
    60                 (cons x rest) ) ) ) )
     28(module datatype (define-datatype
     29                   (cases invoke-variant-case))
     30 
     31  (import scheme chicken)
    6132
    62 (define-macro (cases typename exp . clauses)
    63   (##sys#check-syntax 'cases typename 'symbol)
    64   (let ([tmp (gensym)]
    65         [tag (gensym)] )
    66     `(let ([,tmp ,exp])
    67        (if (##core#check (##sys#structure? ,tmp ',typename))
    68            (let ([,tag (##sys#slot ,tmp 1)])
    69              (cond ,@(map (lambda (clause)
    70                             (if (eq? 'else (car clause))
    71                                 `(else (let () ,@(cdr clause)))
    72                                 (begin
    73                                   (##sys#check-syntax 'cases clause '(symbol #(symbol 0) . #(_ 1)))
    74                                   (let ([variantname (car clause)]
    75                                         [fields (cadr clause)] )
    76                                     `((eq? ,tag ',variantname)
    77                                       (datatype:invoke-variant-case
    78                                        ',variantname ,tmp ,(length fields)
    79                                        (lambda ,fields ,@(cddr clause)) ) ) ) ) ) )
    80                           clauses) ) )
    81            (##sys#signal-hook #:type-error (##core#immutable '"bad argument type to `cases'") ,tmp ',typename) ) ) ) )
     33(define-syntax define-datatype
     34  (lambda (x r c)
     35    (##sys#check-syntax 'define-datatype x '(_ symbol . #(_ 1)))
     36    (let ((typename (cadr x))
     37          (pred (and (symbol? (caddr x)) (caddr x)))
     38          (rest (if (symbol? (caddr x)) (cdddr x) (cddr x)))
     39          (%define (r 'define))
     40          (%begin (r 'begin))
     41          (%if (r 'if)))
     42      `(,%begin
     43        ,@(if pred
     44              `((,%define (,pred x) (##sys#structure? x ',typename)))
     45              '() )
     46        ,@(map (lambda (variant)
     47                 (##sys#check-syntax 'define-datatype variant '(symbol . #((symbol _) 0)))
     48                 (let ((variantname (car variant))
     49                       (fieldnames (map car (cdr variant)))
     50                       (fieldpreds (map cadr (cdr variant))) )
     51                   `(,%define (,(car variant) ,@fieldnames)
     52                              (##sys#make-structure
     53                               ',typename ',variantname
     54                               ,@(map (lambda (name pred)
     55                                        `(,%if (##core#check (,pred ,name))
     56                                               ,name
     57                                               (##sys#signal-hook
     58                                                #:type-error
     59                                                "bad argument type to variant constructor"
     60                                                ,name ',variantname ',name) ) )
     61                                      fieldnames fieldpreds) ) ) ) )
     62               rest)))))
     63
     64(define-syntax cases
     65  (lambda (x r c)
     66    (##sys#check-syntax 'cases x '(_ symbol _ . #(_ 0)))
     67    (let ((typename (cadr x))
     68          (exp (caddr x))
     69          (clauses (cdddr x))
     70          (%let (r 'let))
     71          (%if (r 'if))
     72          (%else (r 'else))
     73          (%eq? (r 'eq?))
     74          (%invoke (r 'invoke-variant-case))
     75          (%lambda (r 'lambda))
     76          (%tmp (r 'tmp))
     77          (%cond (r 'cond))
     78          (%tag (r 'tag)))
     79      `(,%let ((,%tmp ,exp))
     80              (,%if (##core#check (##sys#structure? ,%tmp ',typename))
     81                    (,%let ((,%tag (##sys#slot ,%tmp 1)))
     82                           (,%cond ,@(map (lambda (clause)
     83                                            (cond ((c %else (car clause))
     84                                                   `(,%else (,%let () ,@(cdr clause))))
     85                                                  (else
     86                                                   (##sys#check-syntax 'cases clause '(symbol #(symbol 0) . #(_ 1)))
     87                                                   (let ((variantname (car clause))
     88                                                         (fields (cadr clause)))
     89                                                     `((,%eq? ,%tag ',variantname)
     90                                                       (,%invoke
     91                                                        ',variantname ,%tmp
     92                                                        ,(length fields)
     93                                                        (,%lambda
     94                                                         ,fields
     95                                                         ,@(cddr clause)) ) ) ) ) ) )
     96                                          clauses) ) )
     97                    (##sys#signal-hook #:type-error "bad argument type to `cases'"
     98                                       ,%tmp ',typename) ) ) ) ))
     99
     100(define (invoke-variant-case name block count proc)
     101  (apply
     102   proc
     103   (let ((limit (- (##sys#size block) 2)))
     104     (let rec ((i 0))
     105       (cond ((>= i count) '())
     106             ((>= i limit) (error "too many record fields accessed" name block))
     107             (else (cons (##sys#slot block (+ i 2)) (rec (add1 i)))) ) ) ) ) )
     108
     109)
  • release/4/datatype/datatype.setup

    r1908 r11130  
    11;;;; datatype.setup -*- Scheme -*-
    22
    3 (define hash-exports? (string>=? (chicken-version) "2.310"))
     3(compile -s -O2 -d0 datatype.scm -j datatype)
     4(compile -s -O2 -d0 datatype.import.scm)
    45
    5 (compile -s -O2 -d0
    6         ,@(if hash-exports? '(-check-imports -emit-exports datatype-support.exports) '())
    7         datatype-support.scm)
    8 
    9 (install-extension 'datatype
    10         `("datatype.scm" "datatype-support.so" "datatype.html"
    11                 ,@(if hash-exports? '("datatype-support.exports") '()) )
    12         `((version 1.2)
    13           (syntax)
    14           ,@(if hash-exports? `((exports "datatype-support.exports")) '())
    15           (documentation "datatype.html")
    16           (require-at-runtime datatype-support) ) )
     6(install-extension
     7 'datatype
     8 `("datatype.so" "datatype.import.so")
     9 `((version 1.3)))
Note: See TracChangeset for help on using the changeset viewer.