Psyntax implementation Andre van Tonder 24 Feb 2005 23:22 UTC

Below is an implementation in Dybvig's portable syntax-case, using the
included macro system.  Tested on Petite Chez v6.9c.

Andre

;============================================================================================
; DEPENDENCIES:
;
; Andre van Tonder, 2005.
;
; This section contains an implementation of SRFI-9 and the
; necessary procedures from SRFI-1.  May be omitted if these
; SRFIs are already available.
;
;============================================================================================

; Only the necessary procedures adapted from the SRFI-1 reference
; implementation.  If you have SRFI-1, this may be omitted.  Here I
; didn't bother with optional arguments since only fixed-arity
; versions are needed.

(module srfi-1 (s1:assoc
                 s1:lset-intersection
                 s1:lset-difference
                 s1:delete-duplicates
                 s1:fold-right
                 s1:filter
                 s1:member)

   (define (find pred list)
     (cond ((find-tail pred list) => car)
           (else #f)))

   (define (s1:member x lis =)
     (find-tail (lambda (y) (= x y)) lis))

   (define (find-tail pred list)
     (let lp ((list list))
       (and (not (null-list? list))
            (if (pred (car list)) list
                (lp (cdr list))))))

   (define (s1:assoc x lis =)
     (find (lambda (entry) (= x (car entry))) lis))

   (define (s1:lset-intersection = lis1 . lists)
     (let ((lists (delete lis1 lists eq?)))
       (cond ((any null-list? lists) '())
             ((null? lists)          lis1)
             (else (s1:filter (lambda (x)
                                (every (lambda (lis) (s1:member x lis =))
                                       lists))
                              lis1)))))

   (define (s1:lset-difference = lis1 . lists)
     (let ((lists (s1:filter pair? lists)))
       (cond ((null? lists)     lis1)
             ((memq lis1 lists) '())
             (else (s1:filter (lambda (x)
                                (every (lambda (lis) (not (s1:member x lis =)))
                                       lists))
                              lis1)))))

   (define (every pred list)
     (let lp ((list list))
       (or (not (pair? list))
           (and (pred (car list))
                (lp (cdr list))))))

   (define (delete x lis =)
     (s1:filter (lambda (y) (not (= x y))) lis))

   (define (any pred lis1)
     (and (not (null-list? lis1))
          (let lp ((head (car lis1)) (tail (cdr lis1)))
            (if (null-list? tail)
                (pred head)
                (or (pred head) (lp (car tail) (cdr tail)))))))

   (define (s1:delete-duplicates lis elt=)
     (let recur ((lis lis))
       (if (null-list? lis) lis
           (let* ((x (car lis))
                  (tail (cdr lis))
                  (new-tail (recur (delete x tail elt=))))
             (if (eq? tail new-tail) lis (cons x new-tail))))))

   (define (s1:fold-right kons knil lis1)

     (let recur ((lis lis1))
       (if (null-list? lis) knil
           (let ((head (car lis)))
             (kons head (recur (cdr lis)))))))

   (define null-list? null?)

   (define (s1:filter pred lis)
     (let recur ((lis lis))
       (if (null-list? lis) lis
           (let ((head (car lis))
                 (tail (cdr lis)))
             (if (pred head)
                 (let ((new-tail (recur tail)))
                   (if (eq? tail new-tail) lis
                       (cons head new-tail)))
                 (recur tail))))))
   )

;======================================================================================
; SRFI-9 implementation, based on implementation by Felix Winkelmann.
; If you have SRFI-9, this may be omitted.

(module srfi-9 (s9:define-record-type)

   (import srfi-1)

   (define-syntax (s9:define-record-type x)

     (syntax-case x ()
       ((_ t (conser vars ...) pred slots ...)
        (syntax-case #'(slots ...) ()
          (((slotnames . _) ...)
           (with-syntax ((t (datum->syntax-object #'t (gensym)))
                         ((slotvars ...) (map (lambda (sname)
                                                (if (s1:member sname #'(vars ...) literal-identifier=?)
                                                    sname
                                                    #''<undefined>))
                                              #'(slotnames ...))))
             (with-syntax (((accforms ...)
                            (let loop ((slots #'(slots ...)) (i 2))
                              (if (null? slots)
                                  #'()
                                  (with-syntax ((ii i)
                                                ((rest ...) (loop (cdr slots) (+ 1 i))))
                                    (syntax-case (car slots) ()
                                      ((name get set)
                                       #'((define (get x)
                                            (vector-ref x ii))
                                          (define (set x y)
                                            (vector-set! x ii y))
                                          rest ...))
                                      ((name get)
                                       #'((define (get x)
                                            (vector-ref x ii))
                                          rest ...))))))))
               #'(begin
                   (define (conser vars ...) (vector '<record> 't slotvars ...))
                   (define (pred x) (and (vector? x)
                                         (>= (vector-length x) 2)
                                         (eqv? '<record> (vector-ref x 0))
                                         (eqv? 't (vector-ref x 1))))
                   accforms ...))))))))

   ) ; srfi-9

;===========================================================================================
; SRFI-57: RECORDS IMPLEMENTATION IN PORTABLE SYNTAX-CASE:
;
; Andre van Tonder, 2005.
;
;============================================================================================

(module registry (register
                   make-entry
                   lookup-entry
                   lookup-scheme?
                   lookup-getter
                   lookup-setter
                   lookup-labels
                   lookup-supers
                   lookup-copier
                   lookup-predicate)

   (import srfi-1)
   (import srfi-9)

   (define reg '())

   (s9:define-record-type entry

     (make-entry name
                 is-scheme?
                 predicate
                 supers
                 labels
                 pos-labels
                 fields
                 copier)
     entry?

     (name       entry.name)
     (is-scheme? entry.is-scheme?)
     (predicate  entry.predicate)
     (supers     entry.supers)
     (labels     entry.labels)
     (pos-labels entry.pos-labels)
     (fields     entry.fields)
     (copier     entry.copier))

   (define (register name entry)
     (cond ((s1:assoc name reg literal-identifier=?)
            => (lambda (pair)
                 (set-cdr! pair entry)))
           (else
            (set! reg (cons (cons name entry)
                            reg)))))

   (define (lookup-entry name)
     (s1:assoc name reg literal-identifier=?))

   (define (lookup-getter name label)
     (cond ((s1:assoc label
                      (entry.fields (cdr (lookup-entry name)))
                      literal-identifier=?)
            => cadr)
           (else #f)))

   (define (lookup-setter name label)
     (cond ((s1:assoc label
                      (entry.fields (cdr (lookup-entry name)))
                      literal-identifier=?)
            => caddr)
           (else #f)))

   (define (lookup-scheme? name)   (entry.is-scheme? (cdr (lookup-entry name))))
   (define (lookup-labels name)    (entry.labels     (cdr (lookup-entry name))))
   (define (lookup-supers name)    (entry.supers     (cdr (lookup-entry name))))
   (define (lookup-copier name)    (entry.copier     (cdr (lookup-entry name))))
   (define (lookup-predicate name) (entry.predicate  (cdr (lookup-entry name))))

   ) ; registry

(module portability (syntax->list)

   (define (syntax->list x)
     (syntax-case x ()
       (()      '())
       ((h . t) (cons #'h
                      (syntax->list #'t)))))

   )

(module helpers (parse-declaration
                  build-record
                  extend-predicates
                  extend-copiers
                  extend-accessors
                  populate
                  define-generic
                  make-generic
                  define-method
                  any?)

   (import registry)
   (import srfi-1)
   (import srfi-9)
   (import portability)

   (define-syntax parse-declaration
     (syntax-rules ()
       ((parse-declaration is-scheme? (name super ...) (constructor pos-label ...) predicate field-clause ...)
        (build-record (constructor pos-label ...)  #f (super ...) (field-clause ...) name predicate is-scheme?))
       ((parse-declaration is-scheme? (name super ...) constructor predicate field-clause ...)
        (build-record (constructor)  #t (super ...) (field-clause ...) name predicate is-scheme?))
       ((parse-declaration is-scheme? (name super ...) constructor-clause)
        (parse-declaration is-scheme? (name super ...) constructor-clause #f))
       ((parse-declaration is-scheme? (name super ...))
        (parse-declaration is-scheme? (name super ...) #f #f))
       ((parse-declaration is-scheme? name . rest)
        (parse-declaration is-scheme? (name) . rest))))

   (define-syntax build-record
     (let ()

       (define (build-record stx)
         (syntax-case stx ()
           ((build-record (constructor pos-label ...)
                          default-order?
                          (super ...)
                          ((field-label . accessors) ...)
                          name
                          predicate
                          is-scheme?)
            (with-syntax
                (((label ...)
                  (s1:delete-duplicates (s1:fold-right append
                                                       (syntax->list #'(pos-label ... field-label ...))
                                                       (map lookup-labels
                                                            (syntax->list #'(super ...))))
                                        literal-identifier=?))
                 ((super ...)
                  (s1:delete-duplicates (s1:fold-right append
                                                       '()
                                                       (map lookup-supers
                                                            (syntax->list #'(super ...))))
                                        literal-identifier=?)))
              (with-syntax
                  (((pos-label ...)

                    (if (syntax-object->datum #'default-order?)
                        #'(label ...)
                        #'(pos-label ...)))

                   (((field-label getter setter) ...)

                    (append (map augment-field
                                 (syntax->list #'((field-label . accessors) ...)))
                            (map (lambda (label)
                                   (maybe-generate #'name `(,label getter setter)))
                                 (s1:lset-difference literal-identifier=?
                                                     (syntax->list #'(label ...))
                                                     (syntax->list #'(field-label ...)))))))

                (with-syntax ((supers         #'(super ...))
                              ((pos-temp ...) (generate-temporaries #'(pos-label ...)))
                              ((constructor predicate maker copier)
                               (maybe-generate #'name `(,#'constructor ,#'predicate maker copier))))
                  (begin
                    (register #'name (make-entry #'name
                                                 (syntax-object->datum #'is-scheme?)
                                                 #'predicate
                                                 (syntax->list #'(super ... name))
                                                 (syntax->list #'(label ...))
                                                 (syntax->list #'(pos-label ...))
                                                 (map syntax->list
                                                      (syntax->list #'((field-label getter setter) ...)))
                                                 #'copier))

                    (if (syntax-object->datum #'is-scheme?)

                        #'(begin
                            (define-generic (predicate x) (lambda (x) #f))
                            (define-generic (getter x))
                            ...
                            (define-generic (setter x v))
                            ...
                            (define-generic (copier x)))

                        #'(begin
                            (s9:define-record-type internal-name
                                                   (maker field-label ...)
                                                   predicate
                                                   (field-label getter setter) ...)

                            (define constructor
                              (lambda (pos-temp ...)
                                (populate name maker (field-label ...) (pos-label pos-temp) ...)))

                            (extend-predicates supers predicate)
                            (extend-accessors supers field-label predicate getter setter)
                            ...

                            (define (copier x)
                              (maker (getter x) ...))
                            (extend-copiers supers copier predicate)

                            (define-method (show (r predicate))
                              (list 'name
                                    (list 'field-label (getter r))
                                    ...))

                            (define-syntax name
                              (syntax-rules ()
                                ((name . bindings) (populate name maker (field-label ...) . bindings))))

                            ))))))))) ; build-record

       (define (maybe-generate context maybe-identifiers)
         (map (lambda (elem)
                (if (identifier? elem)
                    elem
                    (datum->syntax-object context (gensym))))
              maybe-identifiers))

       (define (augment-field clause)
         (syntax-case clause ()
           ((label)               (maybe-generate #'label `(,#'label    getter    setter)))
           ((label getter)        (maybe-generate #'label `(,#'label ,#'getter    setter)))
           ((label getter setter) (maybe-generate #'label `(,#'label ,#'getter ,#'setter)))))

       build-record))

   (define-syntax extend-predicates
     (lambda (stx)
       (syntax-case stx ()
         ((extend-predicates (super ...) new-type)
          (with-syntax (((predicate ...) (map lookup-predicate
                                              (syntax->list #'(super ...)))))
            #'(begin
                (define-method predicate (new-type) (x) any?)
                ...))))))

   (define-syntax extend-copiers
     (lambda (stx)
       (syntax-case stx ()
         ((extend-copiers (super ...) copy new-type)
          (with-syntax (((copier ...) (map lookup-copier
                                           (syntax->list #'(super ...)))))
            #'(begin
                (define-method copier (new-type) (x)  copy)
                ...))))))

   (define-syntax extend-accessors
     (lambda (stx)
       (syntax-case stx ()
         ((extend-accessors (super ...) label new-type selector modifier)
          (with-syntax (((getter ...) (s1:filter (lambda (id)
                                                   (not (eqv? id #f)))
                                                 (map (lambda (super)
                                                        (lookup-getter super #'label))
                                                      (syntax->list #'(super ...)))))
                        ((setter ...) (s1:filter (lambda (id)
                                                   (not (eqv? id #f)))
                                                 (map (lambda (super)
                                                        (lookup-setter super #'label))
                                                      (syntax->list #'(super ...))))))
            #'(begin
                (define-method getter (new-type) (x) selector)
                ...
                (define-method setter (new-type any?) (x v) modifier)
                ...))))))

   (define-syntax populate
     (lambda (stx)

       (define (order name ordering bindings default)
         (if (null? (s1:lset-difference literal-identifier=?
                                        (map car bindings)
                                        ordering))
             (map (lambda (label)
                    (cond ((s1:assoc label bindings literal-identifier=?) => (lambda (x) x))
                          (else `(,label ,default))))
                  ordering)
             (error 'populate "Bindings ~s contains illegal labels.  Legal labels for record type ~s are ~s"
                    (syntax-object->datum bindings)
                    (syntax-object->datum name)
                    (syntax-object->datum ordering))))

       (syntax-case stx ()
         ((populate name maker labels . bindings)
          (with-syntax ((((label exp) ...) (order #'name
                                                  (syntax->list #'labels)
                                                  (map syntax->list
                                                       (syntax->list #'bindings))
                                                  #''<undefined>)))
            #'(maker exp ...))))))

   ; Simple generic functions suitable for our disjoint base record types:

   (define-syntax define-generic
     (syntax-rules ()
       ((define-generic (name arg ...))
        (define-generic (name arg ...)
          (lambda (arg ...) (error "Inapplicable method:" 'name
                                   "Arguments:" (show arg) ... ))))
       ((define-generic (name arg ...) proc)
        (define name (make-generic (arg ...) proc)))))

   (define-syntax define-method
     (syntax-rules ()
       ((define-method (generic (arg pred?) ...) . body)
        (define-method generic (pred? ...) (arg ...) (lambda (arg ...) . body)))
       ((define-method generic (pred? ...) (arg ...) procedure)
        (let ((next ((generic) 'get-proc))
              (proc procedure))
          (((generic) 'set-proc)
           (lambda (arg ...)
             (if (and (pred? arg) ...)
                 (proc arg ...)
                 (next arg ...))))))))

   (define-syntax make-generic
     (syntax-rules ()
       ((make-generic (arg arg+ ...) default-proc)
        (let ((proc default-proc))
          (case-lambda
            ((arg arg+ ...)
             (proc arg arg+ ...))
            (()
             (lambda (msg)
               (case msg
                 ((get-proc) proc)
                 ((set-proc) (lambda (new)
                               (set! proc new)))))))))))

   (define (any? x) #t)

   ) ; helpers

(module records (define-record-type
                  define-record-scheme
                  record-update
                  record-update!
                  record-compose
                  show)

   (import srfi-1)
   (import registry)
   (import portability)
   (import helpers)

   (define-syntax define-record-type
     (syntax-rules ()
       ((define-record-type . body)
        (parse-declaration #f . body))))

   (define-syntax define-record-scheme
     (syntax-rules ()
       ((define-record-scheme . body)
        (parse-declaration #t . body))))

   (define-syntax record-update!
     (lambda (stx)
       (syntax-case stx ()
         ((_ record name (label exp) ...)
          (with-syntax (((setter ...)
                         (map (lambda (label)
                                (lookup-setter #'name label))
                              (syntax->list #'(label ...)))))
            #'(let ((r record))
                (setter r exp)
                ...
                r))))))

   (define-syntax record-update
     (lambda (stx)
       (syntax-case stx ()
         ((_ record name (label exp) ...)
          (if (lookup-scheme? #'name)
              (with-syntax ((copier (lookup-copier #'name)))
                #'(let ((new (copier record)))
                    (record-update! new name (label exp) ...)))
              #'(record-compose (name record) (name (label exp) ...)))))))

   (define-syntax record-compose
     (lambda (stx)
       (syntax-case stx ()
         ((record-compose (export-name (label exp) ...))
          #'(export-name (label exp) ...))
         ((record-compose (import-name record) import ... (export-name (label exp) ...))
          (with-syntax
              (((copy-label ...)
                (s1:lset-intersection literal-identifier=?
                                      (lookup-labels #'export-name)
                                      (s1:lset-difference literal-identifier=?
                                                          (lookup-labels #'import-name)
                                                          (syntax->list #'(label ...))))))
            (with-syntax (((getter ...)
                           (map (lambda (label)
                                  (lookup-getter #'import-name label))
                                (syntax->list #'(copy-label ...)))))
              #'(let ((r record))
                  (record-compose import ...
                                  (export-name (copy-label (getter r))
                                               ...
                                               (label exp)
                                               ...)))))))))

   (define-generic (show x)
     (lambda (x) x))

   ) ; records