Re: [Chicken-users] SRFI-57 does not seem to respect type

[Dale Jordan]

Zbigniew Szadkowski wrote:
> Either I am not understanding SRFI-57, or I have found a bug.

This is something of a problem.  One of the original objectives for 
SRFI-57 was to use the new records with a general "match" macro, similar 
but different from the one supplied with chicken.  This got separated 
from srfi-57 and may or may not be forthcoming as a srfi.  In any event, 
with this kind of use, where multiple fields are accessed at once and 
only after the type predicate is satisfied, the individual field 
selections don't need type checking.  I don't know if there is any way 
to satisfy this situation and unguarded selection without both "safe" 
and "unsafe" accessors.

For anyone interested, I have attached a version of "match" that works 
with the srfi-57 egg.  I just append it to srfi-57.scm and reinstall the 
extension.  In addition to (import records), (import matcher).

> [Also, in SRFI-57 the types show up as #<record> instead of #<foo> or
> #<bar>, but I am assuming this is a known limitation.]
Yes, this is because the types are implemented as chicken structures 
with a type of record.  I don't know what the ramifications of changing 
    this are.  I made a small hack changing
   (define generated-tag (cons #f #f))
to
   (define generated-tag (list 'name))

This lets the type show up in the ",d" command in csi.  The 
generated-tag has to be bound to a new list cell to preserve 
"generativity".  Generativity prevents inadvertant name clashes from 
being confused as the same type and prevents forgery, but it means while 
debugging if you change the record definition, any existing records are 
no longer accessible.  :(

BTW, felix, the csi help message is wrong about ",<NUM>" invoking the 
history mechanism -- it seems "#<NUM>" is the correct syntax.

Cheerfully,

Dale Jordan


;;;; Match extension to SRFI-57
;;; Taken from AvT's original srfi-57 reference implementation.
;;; Revised for portable syntax-case and final srfi-57 by Dale Jordan.

(module matcher (match match-lambda)

  (import registry)
  (import portability)

  (define-syntax match 
    (lambda (stx)
      (syntax-case stx (_ => quote cons vector list list* and or = ? quasiquote 
unquote)
        ((match exp . rest)
         (not (identifier? #'exp))
         #'(let ((var exp))
             (match var . rest)))
        ((match var)
         #'(error "No match for" var))
        ((match var (pattern (=> fail) . body) . rest)
         #'(let ((fail (lambda () (match var . rest))))
             (match var (pattern . body) . rest)))
        ((match var (_ . body) . rest)
         #'(begin . body))
        ((match var ((quote x) . body) . rest)
         #'(if (equal? (quote x) var)
               (begin . body)
               (match var . rest)))
        ((match var ((quasiquote ()) . body) . rest)
         #'(if (null? var) 
               (begin . body)
               (match var . rest)))
        ((match var ((quasiquote #(pat ...)) . body) . rest)
         #'(if (vector? var)
               (match (vector->list var)
                          ((list (quasiquote pat) ...) . body) . rest)
               (match var . rest)))
        ((match var ((quasiquote (unquote pat)) . body) . rest)
         #'(match var
                      (pat . body)
                      (_     (match var . rest))))
        ((match var ((quasiquote (pat . pats)) . body) . rest)
         #'(let ((fail (lambda () (match var . rest))))
             (if (pair? var)
                 (match (car var)
                   ((quasiquote pat)
                    (match (cdr var)
                      ((quasiquote pats) . body)
                      (_                 (fail))))
                   (_                (fail)))
                 (fail))))
        ((match var ((quasiquote pat) . body) . rest)
         #'(match var 
                      ((quote pat) . body)
                      (_           (match var . rest))))
        ((match var ((cons pat1 pat2) . body) . rest)
         #'(let ((fail (lambda () (match var . rest))))
             (if (pair? var)
                 (match (car var)
                   (pat1 (match (cdr var)
                           (pat2 . body)
                           (_    (fail))))
                   (_    (fail)))
                 (fail))))
        ((match var ((vector pat ...) . body) . rest)
         #'(if (vector? var)
               (match (vector->list var)
                 ((list pat ...) . body) . rest)
               (match var . rest)))
        ((match var ((list) . body) . rest)
         #'(if (null? var) 
               (begin . body)
               (match var . rest)))
        ((match var ((list pat . pats) . body) . rest)
         #'(let ((fail (lambda () (match var . rest))))
             (if (pair? var)
                 (match (car var)
                   (pat (match (cdr var)
                          ((list . pats) . body)
                          (_             (fail))))
                   (_    (fail)))
                 (fail))))
        ((match var ((list* pat) . body) . rest)
         #'(match var
             (pat . body)
             (_ (match var . rest))))
        ((match var ((list* pat . pats) . body) . rest)
         #'(let ((fail (lambda () (match var . rest))))
             (if (pair? var)
                 (match (car var)
                   (pat (match (cdr var)
                          ((list* . pats) . body)
                          (_             (fail))))
                   (_    (fail)))
                 (fail))))
        ((match var ((and) . body) . rest)
         #'(begin . body))
        ((match var ((and pat . pats) . body) . rest)
         #'(let ((fail (lambda () (match var . rest))))
             (match var
                        (pat
                         (match var
                                    ((and . pats) . body)
                                    (_            (fail))))
                        (_   (fail)))))
        ((match var ((or) . body) . rest)
         #'(match var . rest))
        ((match var ((or pat . pats) . body) . rest)
         #'(match var
                      (pat . body)
                      (_
                       (match var
                                  ((or . pats) . body)
                                  (_ (match var . rest))))))
        ((match var ((= f pat) . body) . rest)
         #'(match (f var)
             (pat . body)
             (_   (match var . rest))))
        ((match var ((? pred? pat ...) . body) . rest)
         #'(let ((fail (lambda () (match var . rest))))
             (if (pred? var)
                 (match var
                            ((and pat ...) . body)
                            (_             (fail)))
                 (fail))))
        ((match var ((name binding ...) . body) . rest)
         (lookup-entry #'name) ; require name is defined record type or scheme
         (with-syntax
             (((binding ...)            ; normalized binding list
               (let ((binds (syntax->list #'(binding ...))))
                 (if (null? binds)      ; expand to all field labels
                     (map (lambda (bind) (list bind bind))
                          (lookup-labels #'name))
                     (map (lambda (bind)
                            (if (identifier? bind)
                                (list bind bind) ; l => (l l)
                                (syntax->list bind))) ; (l var)
                          binds)))))
              (with-syntax
                  ((predicate (lookup-predicate #'name))
                   ((getter ...)
                    (map (lambda (bind) (lookup-getter #'name (car bind)))
                         (syntax->list #'(binding ...))))
                   ((lvar ...)
                    (map (lambda (bind) (cadr bind))
                         (syntax->list #'(binding ...)))))
                #'(if (predicate var)
                      (let ((lvar (getter var)) ...) . body)
                      (match var . rest)))))
        ((match var (x . body) . rest)
         (identifier? #'x)
         #'(let ((x var)) . body))
        ((match var (x . body) . rest)
         #'(if (eqv? x var)
               (begin . body)
               (match var . rest))))))

  (define-syntax match-lambda
    (syntax-rules ()
      ((match-lambda (pat body) ...)
       (lambda (x) (match x (pat body) ...)))))

  ) ;; matcher