Changeset 36080 in project


Ignore:
Timestamp:
08/10/18 00:59:26 (12 months ago)
Author:
Ivan Raikov
Message:

datatype: refactoring record definition to use module prefix for compatibility with define-record-printer

Location:
release/5/datatype/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/5/datatype/trunk/datatype.scm

    r35631 r36080  
    3737  (lambda (x r c)
    3838    (##sys#check-syntax 'define-datatype x '(_ symbol . #(_ 1)))
    39     (let ((typename (cadr x))
    40           (pred (and (symbol? (caddr x)) (caddr x)))
    41           (rest (if (symbol? (caddr x)) (cdddr x) (cddr x)))
    42           (%define (r 'define))
    43           (%begin (r 'begin))
    44           (%if (r 'if)))
     39    (let* ((typename (cadr x))
     40           (pred (and (symbol? (caddr x)) (caddr x)))
     41           (rest (if (symbol? (caddr x)) (cdddr x) (cddr x)))
     42           (plain-name (strip-syntax typename))
     43           (tag (if (##sys#current-module)
     44                    (symbol-append
     45                     (##sys#module-name (##sys#current-module))
     46                     '|#| plain-name)
     47                    plain-name))
     48           (%define (r 'define))
     49           (%begin (r 'begin))
     50           (%if (r 'if)))
    4551      `(,%begin
     52        (,%define ,typename ',tag)
    4653        ,@(if pred
    47               `((,%define (,pred x) (##sys#structure? x ',typename)))
     54              `((,%define (,pred x) (##sys#structure? x ',tag)))
    4855              '() )
    4956        ,@(map (lambda (variant)
     
    5461                   `(,%define (,(car variant) ,@fieldnames)
    5562                              (##sys#make-structure
    56                                ',typename ',variantname
     63                               ',tag ',variantname
    5764                               ,@(map (lambda (name pred)
    5865                                        `(,%if (##core#check (,pred ,name))
     
    7077  (lambda (x r c)
    7178    (##sys#check-syntax 'cases x '(_ symbol _ . #(_ 0)))
    72     (let ((typename (cadr x))
    73           (exp (caddr x))
    74           (clauses (cdddr x))
    75           (%let (r 'let))
    76           (%if (r 'if))
    77           (%else (r 'else))
    78           (%eq? (r 'eq?))
    79           (%invoke (r 'invoke-variant-case))
    80           (%lambda (r 'lambda))
    81           (%tmp (r 'tmp))
    82           (%cond (r 'cond))
    83           (%tag (r 'tag)))
     79    (let* ((typename (cadr x))
     80           (exp (caddr x))
     81           (clauses (cdddr x))
     82           (%let (r 'let))
     83           (%if (r 'if))
     84           (%else (r 'else))
     85           (%eq? (r 'eq?))
     86           (%invoke (r 'invoke-variant-case))
     87           (%lambda (r 'lambda))
     88           (%tmp (r 'tmp))
     89           (%cond (r 'cond))
     90           (%tag (r 'tag)))
    8491      `(,%let ((,%tmp ,exp))
    85               (,%if (##core#check (##sys#structure? ,%tmp ',typename))
     92              (,%if (##core#check (##sys#structure? ,%tmp ,typename))
    8693                    (,%let ((,%tag (##sys#slot ,%tmp 1)))
    8794                           (,%cond ,@(map (lambda (clause)
     
    101108                                          clauses) ) )
    102109                    (##sys#signal-hook #:type-error "bad argument type to `cases'"
    103                                        ,%tmp ',typename) ) ) ) ))
     110                                       ,%tmp ,typename) ) ) ) ))
    104111  )
    105112
  • release/5/datatype/trunk/tests/run.scm

    r36072 r36080  
    11; A simple binary tree with numbers:
    2 (import datatype test)
    3 (require-extension datatype)
     2(import scheme (chicken base) (chicken format) datatype test)
    43
    54(define-datatype tree tree?
     
    1413    (branch (left right) (cons (listify left) (listify right))) ) )
    1514
    16 (assert (equal? '((33 . 44) . 55) (listify t)))
     15(test "listify" '((33 . 44) . 55) (listify t))
    1716
    1817
     18(define-record-printer (tree x out)
     19  (cases tree x
     20    (leaf (n)
     21          (fprintf out "~A" n))
     22    (branch (left right)
     23            (fprintf out "(~A . ~A)" left right))))
     24
     25(test "to string" "((33 . 44) . 55)" (->string t))
     26
     27
     28(test-exit)
     29
Note: See TracChangeset for help on using the changeset viewer.