Re: again: syntax-case and the module system

Hello,

>>>>> "me" =3D=3D Johannes Bruegmann <[email protected]> writes:

    me> Hello, can anybody help me with that?

    me> What is wrong with the following module definition?

I found the time to work on that problem again and i was able to solve
it the following way:

- i rewrote both macros [2]

- using mtrace [1] i was able to trace the macro expansion and locate
the bugs in my code

- the error message "Caused by Error: attempt to apply non-procedure
'#!void'" appeared because of the letrec-behaviour of define-syntax
and disappeared when importing each of the previous definitions into
the lambda body of the define-syntax, like for example in the
definition of an enumerated type color:

;;; the definition of enumerated-type :color
(define-enumerated-type color :color
  color?
  colors
  color-name
  color-index
  (black white purple maroon))


=3D=3D=3D=3D> (output of macro mtrace'd in the last step):

;;; an unnamed module that expands in place =

(module =

    (color colors |%%_rxomFnHre| color? color-name color-index)

  ; use records of SRFI-9
  (import srfi-9)

  ; define a named module that exports all the symbols generated by
  ; macro define-enumerated-type
  (module |%%_rxKiDQHre|
      (colors |%%_rxomFnHre| color? color-name color-index)
    (import srfi-9)
    (define colors #f)
    (define-record-type :color
      (|%%_rxomFnHre| name index)
      color?
      (name color-name)
      (index color-index))
    (set! colors
      (vector
        (|%%_rxomFnHre| 'black 0)
        (|%%_rxomFnHre| 'white (+ 0 1))
        (|%%_rxomFnHre| 'purple (+ (+ 0 1) 1))
        (|%%_rxomFnHre| 'maroon (+ (+ (+ 0 1) 1) 1)))))

  ; make the symbols of the module previously defined available in the
  ; current module definition
  (import |%%_rxKiDQHre|)

  ; import all symbols into the lambda body of define-syntax
  (define-syntax color
    (lambda (t)
      (import |%%_rxKiDQHre|)
      (syntax-case t
        (black white purple maroon)
        ((%_ black) (syntax (vector-ref colors 0)))
        ((%_ white) (syntax (vector-ref colors (+ 0 1))))
        ((%_ purple) (syntax (vector-ref colors (+ (+ 0 1) 1))))
        ((%_ maroon) (syntax (vector-ref colors (+ (+ (+ 0 1) 1) 1))))))))

Maybe somebody has a similiar problem in the future and will find this
helpful.

Regards,
Johannes Br=FCgmann


[1]: http://okmij.org/ftp/Scheme/macro-trace.txt:

;;; mtrace.scm - provide syntax for macro tracing

;;; source from: http://okmij.org/ftp/Scheme/macro-trace.txt

(define-syntax mtrace
  (syntax-rules ()
    ((mtrace x)
     (begin =

      (display "Trace: ") (pretty-print 'x) (newline)
      x))))

(define-syntax rletrec1
  (syntax-rules ()
    ((_ ((var1 init1) ...) body ...)
     (rletrec "generate temp names"
       (var1 ...)
       ()
       ((var1 init1) ...)
       body ...))
    ((_ "generate temp names"
       ()
       (temp1 ...)
       ((var1 init1) ...)
       body ...)
     (let ((var1 #f) ...)
       (let ((temp1 init1) ...)
         (set! var1 temp1)
         ...
         body ...)))
    ((_ "generate temp names"
       (x y ...)
       (temp ...)
       ((var1 init1) ...)
       body ...)
     (rletrec "generate temp names"
       (y ...)
       (newtemp temp ...)
       ((var1 init1) ...)
       body ...))))

(define-syntax rletrec
  (syntax-rules ()
    ((rletrec . args)
     (mtrace (rletrec1 . args)))))



[2]: finite-types.scm:

;;; finite-types.scm - provide syntax for finite types and enumerated types

;;; Copyright (c) 2008 University Duisburg-Essen, Physics of Transport
;;;                    and Traffic, <http://www.ptt.uni-due.de>
;;;
;;; Author: Johannes Br=FCgmann, 05/2008, <[email protected]>
;;;     =

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;; =

;;; THIS SOFTWARE IS PROVIDED BY AUTHOR AND CONTRIBUTORS ``AS IS'' AND
;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURP=
OSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL AUTHOR OR CONTRIBUTORS BE LIABLE
;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENT=
IAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STR=
ICT
;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY W=
AY
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.

;;; finite-types as in Scheme48 =


;;;@
;;;define a finite-type record:
;;;@lisp
;;; (define-finite-type tag type-name
;;;   (field-tag ...)
;;;   predicate-name
;;;   vector-of-instances-name
;;;   name-accessor
;;;   index-accessor
;;;   (field-tag accessor-name [modifier-name])
;;;   ...((instance-name field-value ...)
;;;    ...))
;;;@end lisp
;;;Example from Scheme48 Manual:
;;;@lisp
;;; (define-finite-type color :color
;;;   (red green blue)
;;;   color?
;;;   colors
;;;   color-name
;;;   color-index
;;;   (red   color-red)
;;;   (green color-green)
;;;   (blue  color-blue)
;;;   ((black    0   0   0)
;;;    (white  255 255 255)
;;;    (purple 160  32 240)
;;;    (maroon 176  48  96)))
;;; =

;;; (color-name (color black))         =3D> black
;;; (color-name (vector-ref colors 1)) =3D> white
;;; (color-index (color purple))       =3D> 2
;;; (color-red (color maroon))         =3D> 176
;;;@end lisp
(define-syntax define-finite-type
  (lambda (f)
    (syntax-case f ()
      ((_ tag tnm (col0 col1 ...) pred instvec nm-acc ix-acc (cn0 cnaccs0 .=
..) (cn1 cnaccs1 ...) ... (inst0 inst1 ...))
       (with-syntax (((make-finite-type-record) (generate-temporaries '(1))=
))
	 (syntax (_ (inst0 inst1 ...) =

		    (make-finite-type-record 0) =

		    tag instvec () pred =

		    ((nm-acc ix-acc cnaccs0 ... cnaccs1 ... ...)
		     (define-record-type tnm
		       (make-finite-type-record name index col0 col1 ...)
		       pred
		       (name nm-acc)
		       (index ix-acc)
		       (cn0 cnaccs0 ...) (cn1 cnaccs1 ...) ...))))))

      ((_ ((i0-name i0-val0 i0-val1 ...) inst1 ...) =

	  (make-finite-type-record i rec0 ...) =

	  tag instvec ((nm0 ix0) ...) pred =

	  (exp0 exp1 ...))
       (syntax (_ (inst1 ...) =

		  (make-finite-type-record (+ i 1) rec0 ... (make-finite-type-record 'i0-=
name i i0-val0 i0-val1 ...))
		  tag instvec ((nm0 ix0) ... (i0-name i)) pred =

		  (exp0 exp1 ...))))

      ((_ () =

	  (make-finite-type-record i rec0 rec1 ...) =

	  tag instvec ((nm0 ix0) (nm1 ix1) ...) pred =

	  (exp0 exp1 ...))
       (syntax (_ () () =

		  (make-finite-type-record i rec0 rec1 ...) =

		  tag instvec ((nm0 ix0) (nm1 ix1) ...) pred =

		  (exp0 (define instvec #f) exp1 ... (set! instvec (vector rec0 rec1 ...)=
)))))

      ((_ () () (make-finite-type-record i rec0 rec1 ...) tag instvec ((nm0=
 ix0) (nm1 ix1) ...) pred ((acc0 acc1 ...) exp1 ...))
       (with-syntax (((finite-types-helper) (generate-temporaries '(1))))
	 (syntax (begin
		   (module (tag instvec make-finite-type-record pred acc0 acc1 ...)
		       (import srfi-9)
		     (module finite-types-helper
			 (instvec make-finite-type-record pred acc0 acc1 ...)
		       (import srfi-9)
		       exp1 ...)
		     (import finite-types-helper)
		     (define-syntax tag
		       (lambda (t)
			 (import finite-types-helper)
			 (syntax-case t (nm0 nm1 ...)
			   ((%_ nm0) (syntax (vector-ref instvec ix0)))
			   ((%_ nm1) (syntax (vector-ref instvec ix1)))
			   ...))))))))
)))

;;;@lisp
;;; (define-enumerated-type tag type-name
;;;   predicate-name
;;;   vector-of-instances-name
;;;   name-accessor
;;;   index-accessor
;;;   (instance-name ...))
;;;@end lisp
;;;Example from Scheme48 Manual:
;;;@lisp
;;; (define-enumerated-type color :color
;;;   color?
;;;   colors
;;;   color-name
;;;   color-index
;;;   (black white purple maroon))
;;; =

;;; (color-name (vector-ref colors 0)) =3D> black
;;; (color-name (color white))         =3D> white
;;; (color-index (color purple))       =3D> 2
;;;@end lisp
(define-syntax define-enumerated-type
  (lambda (f)
    (syntax-case f () =

      ((_ tag tnm pred instvec nm-acc ix-acc (inst0 inst1 ...))
       (syntax (and (identifier? tag) (identifier? tnm) (identifier? pred) =
(identifier? nm-acc) (identifier? ix-acc)))
       (with-syntax (((make-enumerated-type-record) (generate-temporaries '=
(1))))
	 (syntax (_ (inst0 inst1 ...) =

		    (make-enumerated-type-record 0) =

		    tag instvec () pred ()
		    ((nm-acc ix-acc)
		     (define-record-type tnm
		       (make-enumerated-type-record name index)
		       pred
		       (name nm-acc)
		       (index ix-acc)))))))

      ((_ (inst0-name inst1-name ...) (make-enumerated-type-record i rec0 .=
..) tag instvec ((nm0 ix0) ...) pred () (exp0 exp1 ...))
       (syntax (_ (inst1-name ...) =

		  (make-enumerated-type-record (+ i 1) rec0 ... (make-enumerated-type-rec=
ord 'inst0-name i))
		  tag instvec ((nm0 ix0) ... (inst0-name i)) pred () (exp0 exp1 ...))))

      ((_ () (make-enumerated-type-record i rec0 rec1 ...) tag instvec ((nm=
0 ix0) (nm1 ix1) ...) pred () (exp0 exp1 ...))
       (syntax (_ () () =

		  (make-enumerated-type-record i rec0 rec1 ...) =

		  tag instvec ((nm0 ix0) (nm1 ix1) ...) pred () =

		  (exp0 (define instvec #f) exp1 ... (set! instvec (vector rec0 rec1 ...)=
)))))

      ((_ () () (make-enumerated-type-record i rec0 rec1 ...) tag instvec (=
(nm0 ix0) (nm1 ix1) ...) pred () ((nm-acc ix-acc) exp1 ...))
       (with-syntax (((enumerated-types-helper) (generate-temporaries '(1))=
))
	 (syntax (begin
		   (module (tag instvec make-enumerated-type-record pred nm-acc ix-acc)
		       (import srfi-9)
		     (module enumerated-types-helper
			 (instvec make-enumerated-type-record pred nm-acc ix-acc)
		       (import srfi-9)
		       exp1 ...)
		     (import enumerated-types-helper)
		     (define-syntax tag
		       (lambda (t)
			 (import enumerated-types-helper)
			 (syntax-case t (nm0 nm1 ...)
			   ((%_ nm0) (syntax (vector-ref instvec ix0)))
			   ((%_ nm1) (syntax (vector-ref instvec ix1)))
			   ...))))))))
)))

--
       W=FCrdig  bist  du,  o  Herr,  zu empfangen den Ruhm und die Ehre un=
d die
       Macht; denn du hast alle Dinge geschaffen, und durch deinen Willen s=
ind
       sie und wurden sie geschaffen!

                                                Offenbarung 4, 11

-------------------------------------------------------------------------
This SF.Net email is sponsored by the Moblin Your Move Developer's challenge
Build the coolest Linux based applications with Moblin SDK & win great priz=
es
Grand prize is a trip for two to an Open Source event anywhere in the world
http://moblin-contest.org/redirect.php?banner_id=3D100&url=3D/