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

Code sample pair: SRFI-9

This page is part of the web mail archives of SRFI 110 from before July 7th, 2015. The new archives for SRFI 110 contain all messages, not just those from before July 7th, 2015.



Here's a code sample from SRFI-9, in both s-expressions (the original) and sweet-expressions.  This demonstrates how these s-expressions can be represented as sweet-expressions.  My hope is that this (and other examples) shows that sweet-expressions are readable to a wider audience.

I'm pasting it below; you can get these as files from the http://readable.sourceforge.net git repo ("develop" branch).  In the sweet-expressions I'm always using "!" as the first indent character, which is certainly not required but it deals with mail readers that gobble up leading spaces.

 --- David A. Wheeler


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; As s-expressions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; This code is from SRFI-9 by Richard Kelsey,
; http://srfi.schemers.org/srfi-9/srfi-9.html
; According to "Scheme Systems Supporting SRFIs" by John Cowan
; (http://spreadsheets.google.com/pub?key=tRCHK6jWXuKMABKAfoOwWqw&output=html)
; this is the most widely implemented Scheme SFRI.

; Syntax definitions

; Definition of DEFINE-RECORD-TYPE

(define-syntax define-record-type
  (syntax-rules ()
    ((define-record-type type
       (constructor constructor-tag ...)
       predicate
       (field-tag accessor . more) ...)
     (begin
       (define type
         (make-record-type 'type '(field-tag ...)))
       (define constructor
         (record-constructor type '(constructor-tag ...)))
       (define predicate
         (record-predicate type))
       (define-record-field type field-tag accessor . more)
       ...))))

; An auxilliary macro for define field accessors and modifiers.
; This is needed only because modifiers are optional.

(define-syntax define-record-field
  (syntax-rules ()
    ((define-record-field type field-tag accessor)
     (define accessor (record-accessor type 'field-tag)))
    ((define-record-field type field-tag accessor modifier)
     (begin
       (define accessor (record-accessor type 'field-tag))
       (define modifier (record-modifier type 'field-tag))))))

; Record types

; We define the following procedures:
; 
; (make-record-type <type-name <field-names>)    -> <record-type>
; (record-constructor <record-type<field-names>) -> <constructor>
; (record-predicate <record-type>)               -> <predicate>
; (record-accessor <record-type <field-name>)    -> <accessor>
; (record-modifier <record-type <field-name>)    -> <modifier>
;   where
; (<constructor> <initial-value> ...)         -> <record>
; (<predicate> <value>)                       -> <boolean>
; (<accessor> <record>)                       -> <value>
; (<modifier> <record> <value>)         -> <unspecific>

; Record types are implemented using vector-like records.  The first
; slot of each record contains the record's type, which is itself a
; record.

(define (record-type record)
  (record-ref record 0))

;----------------
; Record types are themselves records, so we first define the type for
; them.  Except for problems with circularities, this could be defined as:
;  (define-record-type :record-type
;    (make-record-type name field-tags)
;    record-type?
;    (name record-type-name)
;    (field-tags record-type-field-tags))
; As it is, we need to define everything by hand.

(define :record-type (make-record 3))
(record-set! :record-type 0 :record-type)	; Its type is itself.
(record-set! :record-type 1 ':record-type)
(record-set! :record-type 2 '(name field-tags))

; Now that :record-type exists we can define a procedure for making more
; record types.

(define (make-record-type name field-tags)
  (let ((new (make-record 3)))
    (record-set! new 0 :record-type)
    (record-set! new 1 name)
    (record-set! new 2 field-tags)
    new))

; Accessors for record types.

(define (record-type-name record-type)
  (record-ref record-type 1))

(define (record-type-field-tags record-type)
  (record-ref record-type 2))

;----------------
; A utility for getting the offset of a field within a record.

(define (field-index type tag)
  (let loop ((i 1) (tags (record-type-field-tags type)))
    (cond ((null? tags)
           (error "record type has no such field" type tag))
          ((eq? tag (car tags))
           i)
          (else
           (loop (+ i 1) (cdr tags))))))

;----------------
; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the
; procedures used by the macro expansion of DEFINE-RECORD-TYPE.

(define (record-constructor type tags)
  (let ((size (length (record-type-field-tags type)))
        (arg-count (length tags))
        (indexes (map (lambda (tag)
                        (field-index type tag))
                      tags)))
    (lambda args
      (if (= (length args)
             arg-count)
          (let ((new (make-record (+ size 1))))
            (record-set! new 0 type)
            (for-each (lambda (arg i)
			(record-set! new i arg))
                      args
                      indexes)
            new)
          (error "wrong number of arguments to constructor" type args)))))

(define (record-predicate type)
  (lambda (thing)
    (and (record? thing)
         (eq? (record-type thing)
              type))))

(define (record-accessor type tag)
  (let ((index (field-index type tag)))
    (lambda (thing)
      (if (and (record? thing)
               (eq? (record-type thing)
                    type))
          (record-ref thing index)
          (error "accessor applied to bad value" type tag thing)))))

(define (record-modifier type tag)
  (let ((index (field-index type tag)))
    (lambda (thing value)
      (if (and (record? thing)
               (eq? (record-type thing)
                    type))
          (record-set! thing index value)
          (error "modifier applied to bad value" type tag thing)))))

; Records

; This implements a record abstraction that is identical to vectors,
; except that they are not vectors (VECTOR? returns false when given a
; record and RECORD? returns false when given a vector).  The following
; procedures are provided:
;   (record? <value>)                -> <boolean>
;   (make-record <size>)             -> <record>
;   (record-ref <record> <index>)    -> <value>
;   (record-set! <record> <index> <value>) -> <unspecific>
;
; These can implemented in R5RS Scheme as vectors with a distinguishing
; value at index zero, providing VECTOR? is redefined to be a procedure
; that returns false if its argument contains the distinguishing record
; value.  EVAL is also redefined to use the new value of VECTOR?.

; Define the marker and redefine VECTOR? and EVAL.

(define record-marker (list 'record-marker))

(define real-vector? vector?)

(define (vector? x)
  (and (real-vector? x)
       (or (= 0 (vector-length x))
	   (not (eq? (vector-ref x 0)
		record-marker)))))

; This won't work if ENV is the interaction environment and someone has
; redefined LAMBDA there.

(define eval
  (let ((real-eval eval))
    (lambda (exp env)
      ((real-eval `(lambda (vector?) ,exp))
       vector?))))

; Definitions of the record procedures.

(define (record? x)
  (and (real-vector? x)
       (< 0 (vector-length x))
       (eq? (vector-ref x 0)
            record-marker)))

(define (make-record size)
  (let ((new (make-vector (+ size 1))))
    (vector-set! new 0 record-marker)
    new))

(define (record-ref record index)
  (vector-ref record (+ index 1)))

(define (record-set! record index value)
  (vector-set! record (+ index 1) value))


; Copyright (C) Richard Kelsey (1999). All Rights Reserved.
;
; Permission is hereby granted, free of charge, to any person obtaining a
; copy of this software and associated documentation files (the "Software"),
; to deal in the Software without restriction, including without limitation
; the rights to use, copy, modify, merge, publish, distribute, sublicense,
; and/or sell copies of the Software, and to permit persons to whom the
; Software is furnished to do so, subject to the following conditions:
; 
; The above copyright notice and this permission notice shall be included
; in all copies or substantial portions of the Software.
; 
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
; OTHER DEALINGS IN THE SOFTWARE.





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; As sweet-expressions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; This code is from SRFI-9 by Richard Kelsey,
; http://srfi.schemers.org/srfi-9/srfi-9.html
; According to "Scheme Systems Supporting SRFIs" by John Cowan
; (http://spreadsheets.google.com/pub?key=tRCHK6jWXuKMABKAfoOwWqw&output=html)
; this is the most widely implemented Scheme SFRI.

; Syntax definitions

; Definition of DEFINE-RECORD-TYPE

define-syntax define-record-type
! syntax-rules ()
!   \\
!     define-record-type
!       type
!       constructor constructor-tag ...
!       predicate
!       field-tag accessor . more
!       ...
!     begin
!       define type
!       ! make-record-type 'type 'field-tag(...)
!       define constructor
!       ! record-constructor type 'constructor-tag(...)
!       define predicate record-predicate(type)
!       define-record-field type field-tag accessor . more
!       ...

; An auxilliary macro for define field accessors and modifiers.
; This is needed only because modifiers are optional.

define-syntax define-record-field
! syntax-rules ()
!   define-record-field(type field-tag accessor)
!     define accessor record-accessor(type 'field-tag)
!   define-record-field(type field-tag accessor modifier)
!     begin
!       define accessor record-accessor(type 'field-tag)
!       define modifier record-modifier(type 'field-tag)

; Record types

; We define the following procedures:
; 
; (make-record-type <type-name <field-names>)    -> <record-type>
; (record-constructor <record-type<field-names>) -> <constructor>
; (record-predicate <record-type>)               -> <predicate>
; (record-accessor <record-type <field-name>)    -> <accessor>
; (record-modifier <record-type <field-name>)    -> <modifier>
;   where
; (<constructor> <initial-value> ...)         -> <record>
; (<predicate> <value>)                       -> <boolean>
; (<accessor> <record>)                       -> <value>
; (<modifier> <record> <value>)         -> <unspecific>

; Record types are implemented using vector-like records.  The first
; slot of each record contains the record's type, which is itself a
; record.

define record-type(record) record-ref(record 0)

;----------------
; Record types are themselves records, so we first define the type for
; them.  Except for problems with circularities, this could be defined as:
;  (define-record-type :record-type
;    (make-record-type name field-tags)
;    record-type?
;    (name record-type-name)
;    (field-tags record-type-field-tags))
; As it is, we need to define everything by hand.

define :record-type make-record(3)
record-set! :record-type 0 :record-type; Its type is itself.
record-set! :record-type 1 ':record-type
record-set! :record-type 2 'name(field-tags)

; Now that :record-type exists we can define a procedure for making more
; record types.

define make-record-type(name field-tags)
! let <* new $ make-record 3 *>
!   record-set! new 0 :record-type
!   record-set! new 1 name
!   record-set! new 2 field-tags
!   new

; Accessors for record types.

define record-type-name(record-type)
! record-ref record-type 1

define record-type-field-tags(record-type)
! record-ref record-type 2

;----------------
; A utility for getting the offset of a field within a record.

define field-index(type tag)
! let loop <* i 1 \\ tags $ record-type-field-tags type *>
!   cond
!     null?(tags) error("record type has no such field" type tag)
!     eq?(tag car(tags)) i
!     else loop({i + 1} cdr(tags))

;----------------
; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the
; procedures used by the macro expansion of DEFINE-RECORD-TYPE.

define record-constructor(type tags)
! let
!   \\
!     size      $ length record-type-field-tags(type)
!     arg-count $ length tags
!     indexes   $ map lambda(tag() field-index(type tag)) tags
!   lambda args
!     if {length(args) = arg-count}
!       let (new(make-record{size + 1}))
!       ! record-set! new 0 type
!       ! for-each lambda(arg(i) record-set!(new i arg)) args indexes
!       ! new
!       error "wrong number of arguments to constructor" type args

define record-predicate(type)
! lambda thing()
!   {record?(thing) and eq?(record-type(thing) type)}

define record-accessor(type tag)
! let <* index $ field-index type tag *>
!   lambda thing()
!     if {record?(thing) and eq?(record-type(thing) type)}
!       record-ref thing index
!       error "accessor applied to bad value" type tag thing

define record-modifier(type tag)
! let <* index $ field-index type tag *>
!   lambda thing(value)
!     if {record?(thing) and eq?(record-type(thing) type)}
!       record-set! thing index value
!       error "modifier applied to bad value" type tag thing

; Records

; This implements a record abstraction that is identical to vectors,
; except that they are not vectors (VECTOR? returns false when given a
; record and RECORD? returns false when given a vector).  The following
; procedures are provided:
;   (record? <value>)                -> <boolean>
;   (make-record <size>)             -> <record>
;   (record-ref <record> <index>)    -> <value>
;   (record-set! <record> <index> <value>) -> <unspecific>
;
; These can implemented in R5RS Scheme as vectors with a distinguishing
; value at index zero, providing VECTOR? is redefined to be a procedure
; that returns false if its argument contains the distinguishing record
; value.  EVAL is also redefined to use the new value of VECTOR?.

; Define the marker and redefine VECTOR? and EVAL.

define record-marker list('record-marker)

define real-vector? vector?

define vector?(x)
! and
!   real-vector? x
!   or
!     {0 = vector-length(x)}
!     not eq?(vector-ref(x 0) record-marker)

; This won't work if ENV is the interaction environment and someone has
; redefined LAMBDA there.

define eval
! let <* real-eval eval *>
!   lambda exp(env)
!     real-eval(`lambda(vector?() ,exp)) vector?

; Definitions of the record procedures.

define record?(x)
! and
!   real-vector? x
!   {0 < vector-length(x)}
!   eq? vector-ref(x 0) record-marker

define make-record(size)
! let <* new make-vector{size + 1} *>
!   vector-set! new 0 record-marker
!   new

define record-ref(record index)
! vector-ref record {index + 1}

define record-set!(record index value)
! vector-set! record {index + 1} value


; Copyright (C) Richard Kelsey (1999). All Rights Reserved.
;
; Permission is hereby granted, free of charge, to any person obtaining a
; copy of this software and associated documentation files (the "Software"),
; to deal in the Software without restriction, including without limitation
; the rights to use, copy, modify, merge, publish, distribute, sublicense,
; and/or sell copies of the Software, and to permit persons to whom the
; Software is furnished to do so, subject to the following conditions:
; 
; The above copyright notice and this permission notice shall be included
; in all copies or substantial portions of the Software.
; 
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
; OTHER DEALINGS IN THE SOFTWARE.