[Larceny-users] quote-like form

[will at ccs.neu.edu]

David Van Horn wrote:

> Suppose I define a cons-like structure and I want to provide a form that 
> is like quote, but produces my cons-like things when it quotes syntactic 
> pairs.  In particular, I need the form to respect the eq?-ness 
> requirements on quoted pairs, so that:
> 
>     (define (f) '(x))
>     (eq? (f) (f))     => #t
> 
> I wonder if someone could sketch how to do this in Larceny?

To do this in R6 Scheme, you have to rely on libraries being
invoked only once, which is not a portable assumption.

Please note the comment about the all-in-one-file bug in Larceny
v0.97.  I didn't know about that bug until I tested this code.

Will


;;; The following code would not work in implementations that
;;; invoke libraries multiple times.
;;;
;;; Larceny is supposed to invoke libraries only once.
;;;
;;; In Larceny v0.97, however, a bug causes the libraries to be
;;; invoked twice if they're in the same file with the top-level
;;; program.  The following code appears to work in Larceny v0.97
;;; so long as the top-level program is not in the same file as
;;; the libraries.

(library (mycons auxiliary)

  (export mycons mycar mycdr                   ; used by clients of (mycons)
      	  new-label-for fetch-labelled-thing)  ; used only by myquote

  (import (rnrs base)
          (rnrs hashtables))

  (define label-counter 0)                     ; largest label in use

  (define label-table                          ; maps labels to things
    (make-hashtable (lambda (x) x) =))

  (define (new-label-for y)
    (set! label-counter (+ 1 label-counter))
    (hashtable-set! label-table label-counter (make-thing y))
    label-counter)

  (define (fetch-labelled-thing label)
    (hashtable-ref label-table label 'this-never-matters))

  ; For this example, the things are just vectors.

  (define (make-thing y)
    (list->vector y))

  (define (mycons x y)
    (list->vector (cons x (vector->list y))))

  (define (mycar x)
    (vector-ref x 0))

  (define (mycdr x)
    (list->vector (cdr (vector->list x))))

) ; end of (mycons auxiliary)

(library (mycons)

  (export myquote mycons mycar mycdr)

  (import (for (rnrs base) run expand)
          (for (rnrs syntax-case) expand)
          (for (mycons auxiliary) run expand))

  (define-syntax myquote
    (lambda (x0)
      (syntax-case x0 ()
       ((_ x)
      	(let* ((y (syntax->datum #'x))
	       (label (new-label-for y)))
          #`(fetch-labelled-thing #,label))))))

) ; end of (mycons)

;;; For	Larceny	v0.97, this top-level program has to be
;;; in a separate file.  That's	a bug.

(import (rnrs base)
        (rnrs io simple)
	(mycons))

(define (f) (myquote (a b c)))

(define thing0 (myquote ()))

(define thing1 (myquote (a b c)))

(define thing2 (f))

(define thing3 (f))

(write (list thing0 thing1 thing2 thing3))
(newline)

(write (list (mycar thing1) (mycdr thing1)))
(newline)

(write (list (eq? thing1 thing1)
             (eq? thing1 thing2)
             (eq? thing1 thing3)
             (eq? thing2 thing2)
             (eq? thing2 thing3)
             (eq? thing3 thing3)))
(newline)

;;; end of top-level test program