[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Psyntax implementation



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