again: syntax-case and the module system
Johannes Bruegmann <[email protected]> Wed, 21 May 2008 17:40:57 +0200
| Newsgroups | gmane.comp.java.sisc.user |
|---|---|
| Message-ID | <[email protected]> |
Hello,
can anybody help me with that?
What is wrong with the following module definition?
Regards and thanks in advance,
Johannes Br=FCgmann
SISC (1.16.6)
> (load "/home/bruegmann/mod-color.scm")
Error in load: evaluation error at file:/home/bruegmann/mod-color.scm:5:1
---------------------------
console:2:1: <from call to load>
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D
Caused by Error: attempt to apply non-procedure '#!void'.
I don't understand why this error message appears.
the files used are:
;; ------------------------------
;; - mod-color.scm:
;; ------------------------------
(require-library 'sisc/libs/srfi)
;; thats where the finite-types are
(require-library 'sisc/misc/misc)
(module mod-color
((color (define-finite-type)) color? colors color-name color-index colo=
r-red color-green color-blue
(color2 (define-enumerated-type)) color2? colors2 color2-name color2-i=
ndex)
(import srfi-9)
(import srfi-60)
(import finite-types)
(include "color.scm")
)
;; ------------------------------
;; - color.scm:
;; ------------------------------
(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)))
(define-enumerated-type color2 :color2
color2?
colors2
color2-name
color2-index
(black white purple maroon))
;; ------------------------------
;; - module-definition for finite-types.scm:
;; ------------------------------
(module finite-types
((define-finite-type (define-record-type)) (define-enumerated-type (def=
ine-record-type)))
(import srfi-9)
(import srfi-60)
(include "finite-types.scm")
)
;; ------------------------------
;; - 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
(letrec ((really-define-finite-type
(lambda (g)
(syntax-case g ()
((_ ((iname0 iindex0 . fvals0) ... (inameN iindexN . fvalsN=
))
tag type-name (ftag0 ftag1 ...)
predicate-name vector-of-instances-name name-accessor i=
ndex-accessor
(field-tag0 accessor-name0 . ?modifier-name0) (field-ta=
g1 accessor-name1 . ?modifier-name1) ...
((instance-name1 fval1-0 fval1-1 ...) (instance-name2 f=
val2-0 fval2-1 ...) ...))
(really-define-finite-type
(syntax (_ ((iname0 iindex0 . fvals0) ... (inameN iindexN=
. fvalsN) (instance-name1 (+ 1 iindexN) fval1-0 fval1-1 ...))
tag type-name (ftag0 ftag1 ...)
predicate-name vector-of-instances-name name-a=
ccessor index-accessor
(field-tag0 accessor-name0 . ?modifier-name0) =
(field-tag1 accessor-name1 . ?modifier-name1) ...
((instance-name2 fval2-0 fval2-1 ...) ...)))))
((_ ((iname0 iindex0 fval0-0 fval0-1 ...) (iname1 iindex1 =
fval1-0 fval1-1 ...) ...)
tag type-name (ftag0 ftag1 ...)
predicate-name vector-of-instances-name name-accessor =
index-accessor
(field-tag0 accessor-name0 . ?modifier-name0) (field-t=
ag1 accessor-name1 . ?modifier-name1) ...
())
(syntax (begin
(define-record-type type-name
(make-finite-type-record n i ftag0 ftag1 ...)
predicate-name
(n name-accessor)
(i index-accessor)
(field-tag0 accessor-name0 . ?modifier-name0)
(field-tag1 accessor-name1 . ?modifier-name1)
...)
(define vector-of-instances-name
(vector (make-finite-type-record 'iname0 iinde=
x0 fval0-0 fval0-1 ...)
(make-finite-type-record 'iname1 iinde=
x1 fval1-0 fval1-1 ...)
...))
(define-syntax tag
(lambda (t)
(syntax-case t (iname0 iname1 ...)
((_ iname0) (syntax (vector-ref vector-of-=
instances-name iindex0)))
((_ iname1) (syntax (vector-ref vector-of-=
instances-name iindex1)))
...))))))))))
(lambda (f)
(syntax-case f ()
((_ tag type-name (ftag0 ftag1 ...)
predicate-name vector-of-instances-name name-accessor index-acc=
essor
(field-tag0 accessor-name0 . ?modifier-name0) (field-tag1 acces=
sor-name1 . ?modifier-name1) ...
((instance-name0 fval0-0 fval0-1 ...) (instance-name1 fval1-0 f=
val1-1 ...) ...))
(really-define-finite-type
(syntax (really-define-finite-type ((instance-name0 0 fval0-0 fva=
l0-1 ...))
tag type-name (ftag0 ftag1 ...)
predicate-name vector-of-insta=
nces-name name-accessor index-accessor
(field-tag0 accessor-name0 . ?=
modifier-name0) (field-tag1 accessor-name1 . ?modifier-name1) ...
((instance-name1 fval1-0 fval1=
-1 ...) ...)))))))))
;;;@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
(letrec ((really-define-enumerated-type
(lambda (s)
(syntax-case s ()
((_ ((iname0 iindex0) ... (inameN iindexN))
tag type-name
predicate-name vector-of-instances-name name-accessor i=
ndex-accessor
(instance-name1 instance-name2 ...))
(really-define-enumerated-type
(syntax (_ ((iname0 iindex0) ... (inameN iindexN) (instan=
ce-name1 (+ 1 iindexN)))
tag type-name
predicate-name vector-of-instances-name name-a=
ccessor index-accessor
(instance-name2 ...)))))
((_ ((iname0 iindex0) (iname1 iindex1) ...)
tag type-name
predicate-name vector-of-instances-name name-accessor i=
ndex-accessor
())
(syntax (begin
(define-record-type type-name
(make-enumeration-record n i)
predicate-name
(n name-accessor)
(i index-accessor))
(define vector-of-instances-name
(vector (make-enumeration-record 'iname0 iinde=
x0)
(make-enumeration-record 'iname1 iinde=
x1)
...))
(define-syntax tag
(lambda (t)
(syntax-case t (iname0 iname1 ...)
((_ iname0) (syntax (vector-ref vector-of-=
instances-name iindex0)))
((_ iname1) (syntax (vector-ref vector-of-=
instances-name iindex1)))
...))))))))))
(lambda (e)
(syntax-case e ()
((_ tag type-name
predicate-name vector-of-instances-name name-accessor index-acc=
essor
(instance-name0 instance-name1 ...))
(really-define-enumerated-type
(syntax (really-define-enumerated-type ((instance-name0 0))
tag type-name
predicate-name vector-of-i=
nstances-name name-accessor index-accessor
(instance-name1 ...)))))))=
))
-- =
Jesus spricht: Gott ist Geist, und die ihn anbeten, m=FCssen ihn im =
Geist
und in der Wahrheit anbeten.
Johannes 4, 24
-------------------------------------------------------------------------
This SF.net email is sponsored by: Microsoft =
Defy all challenges. Microsoft(R) Visual Studio 2008. =
http://clk.atdmt.com/MRT/go/vse0120000070mrt/direct/01/