This is the mail archive of the
kawa@sources.redhat.com
mailing list for the Kawa project.
Re: Portable Syntax Case
On Fri, 2004-04-23 at 10:33, Per Bothner wrote:
> Adam Warner wrote:
>
> > Through trial and error I have managed to trim a test case down to
> > around 200 lines of code.
>
> I got it down to 10 lines:
>
> (test "Test." 'from-psyntax
> ((lambda ()
> (letrec ((topfun
> (lambda (marks)
> ((lambda ()
> ((lambda ()
> (lambda () marks)))))))
> (chifun
> (lambda () (list topfun))))
> "Test."))))
>
> It's important to minimize the testcases, not just to simplify
> debugging, but also to add them to the testsuite (which I did).
>
> I checked in a patch.
Thank you very much Per. It's a fantastic step ahead that psyntax.pp
loads. Attached is my Kawa-specific file which must be loaded first. It
contains a new definition of eval:
(eval `(set! eval (lambda (expr #!optional env-specifier)
(if (and (list? expr) (string=? (car expr) "noexpand"))
(cadr expr)
(if env-specifier
(,eval expr env-specifier)
(,eval expr))))))
Refer psyntax.ss for details. When the expression to be evaluated
contains the string "noexpand" in the first list position the remainder
of the list is returned unevaluated.
Unfortunately the psyntax.pp code doesn't work. One issue is that while
psyntax.pp can be loaded it still cannot be compiled. Another is that
the syntax-case expander (sc-expand) is simply not working (here I've
chosen to expand the canonical example from "Writing Hygienic Macros in
Scheme with Syntax-Case"):
(sc-expand '(define-syntax and2 (lambda (x) (syntax-case x () ((_ x y) (syntax (if x y #f)))))))
Argument #0 to 'vector-ref' has wrong type
at gnu.mapping.WrongType.make(WrongType.java:56)
at kawa.lib.vectors.apply2(/home/adam/files/kawa/build-1.7.90+2/kawa/kawa/lib/vectors.scm)
at gnu.expr.ModuleBody.applyN(ModuleBody.java:173)
at kawa.lib.vectors.applyN(/home/adam/files/kawa/build-1.7.90+2/kawa/kawa/lib/vectors.scm)
at gnu.expr.ModuleMethod.applyN(ModuleMethod.java:106)
at gnu.expr.ModuleMethod.applyV(ModuleMethod.java:134)
at gnu.expr.GenericProc.applyN(GenericProc.java:86)
at gnu.mapping.ProcedureN.apply2(ProcedureN.java:39)
at atInteractiveLevel$frame44.lambda223(psyntax.pp:384)
at atInteractiveLevel$frame44.apply1(psyntax.pp)
at gnu.expr.ModuleBody.applyN(ModuleBody.java:171)
at gnu.expr.ModuleMethod.applyN(ModuleMethod.java:106)
at gnu.mapping.Procedure.apply(Procedure.java:115)
at gnu.mapping.CallContext.runUntilDone(CallContext.java:289)
at gnu.expr.ModuleExp.evalModule(ModuleExp.java:191)
at kawa.Shell.run(Shell.java:233)
at kawa.Shell.run(Shell.java:180)
at kawa.Shell.run(Shell.java:167)
at kawa.Shell.run(Shell.java:154)
at kawa.repl.main(repl.java:650)
Caused by: java.lang.ClassCastException
... 19 more
A simple test case is (sc-expand '(+ 1 2)) which should return (+ 1 2).
Instead I get the "Argument #0 to 'vector-ref' has wrong type" error
above.
By replacing all references to vector-ref in psyntax.pp with vref and
defining vref as:
(define (vref vector k) (begin (format #t "(vector-ref ~S ~S)~%" vector k) (vector-ref vector k)))
I obtain this extra information:
(vector-ref #<environment interaction-environment.1> 2)
Argument #0 to 'vector-ref' has wrong type
I tried to use SISC as a comparison but am unable to load psyntax.pp
into SISC without receiving a java.lang.OutOfMemoryError. I also
modified its Primitives.java to print out the vector-ref arguments but
this makes compilation too slow (I aborted. Vectors are used extensively
in the compilation process).
Regards,
Adam
(require 'list-lib)
(define (make-hash)
(make <java.util.Hashtable>))
(define (hash-ref hashtable :: <java.util.Hashtable> key)
(let ((value (invoke hashtable 'get key)))
(if (eq? value #!null) #f value)))
(define (hash-set! hashtable :: <java.util.Hashtable> key value)
(invoke hashtable 'put key value))
(define (hash-rm! hashtable :: <java.util.Hashtable> key)
(invoke hashtable 'remove key))
(define (void) (values))
(define (andmap f first . rest)
(or (null? first)
(if (null? rest)
(let andmap ((first first))
(let ((x (car first)) (first (cdr first)))
(if (null? first)
(f x)
(and (f x) (andmap first)))))
(let andmap ((first first) (rest rest))
(let ((x (car first))
(xr (map car rest))
(first (cdr first))
(rest (map cdr rest)))
(if (null? first)
(apply f (cons x xr))
(and (apply f (cons x xr)) (andmap first rest))))))))
(define (ormap proc list1)
(and (not (null? list1))
(or (proc (car list1)) (ormap proc (cdr list1)))))
(define (gensym) (gentemp))
(define getprop #f)
(define putprop #f)
(define remprop #f)
(let ((property-hash (make-hash)))
(set! getprop (lambda (symbol key)
(let ((alist (hash-ref property-hash symbol)))
(if alist (assq key alist) #f))))
;;putprop has no well-defined return value
(set! putprop (lambda (symbol key value)
(let ((alist (hash-ref property-hash symbol)))
(if alist
(begin (set! alist (alist-delete! key alist eq?))
(hash-set! property-hash symbol
(alist-cons key value alist)))
(hash-set! property-hash symbol
(alist-cons key value '()))))))
;;remprop has no well-defined return value
(set! remprop (lambda (symbol key)
(let ((alist (hash-ref property-hash symbol)))
(when alist
(set! alist (alist-delete! key alist eq?))
(if (null? alist)
(hash-rm! property-hash symbol)
(hash-set! property-hash symbol alist)))))))
(eval `(set! eval (lambda (expr #!optional env-specifier)
(if (and (list? expr) (string=? (car expr) "noexpand"))
(cadr expr)
(if env-specifier
(,eval expr env-specifier)
(,eval expr))))))