syntax-case in the repl and in the module system
Johannes Bruegmann <[email protected]> Mon, 19 May 2008 18:29:41 +0200
| Newsgroups | gmane.comp.java.sisc.user |
|---|---|
| Message-ID | <[email protected]> |
Hello,
i tried to port the SCSH-awk-macro from the MzScheme-port to
SISC. That worked - like the following session shows (the files
referenced in the comment can be found at the end of this mail):
SISC (1.16.6)
> (load "test.scm") ; [1] test.scm, [2] test.txt [3] awk.scm
lines-taken: 2
lines-dropped: 1
> awk-result
(("1" "col1" "col2") ("3" "good" "bye"))
Having that, i thought to myself it could be handy to have that code
in a module with the module description listed under [4]. But loading
that module description fails like follows:
> (load "mod-awk.scm") ; [4] mod-awk.scm
Error in load: evaluation error at file:/home/bruegmann/du/cvs-modules/=
sisc-jars/awk/mod-awk.scm:7:1
---------------------------
console:3:1: <from call to load>
---------------------------
Some stack trace entries may have been suppressed. To see all entries s=
et the dynamic parameter suppressed-stack-trace-source-kinds to '().
=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: identifier out of context syntax->list
> ^D
I don't know why that specific error appears - but i tested if the
procedure syntax->list would be ok in an isolated module:
SISC (1.16.6)
> (load "mod-synlist.scm") ; [5] mod-synlist.scm [6] synlist.scm
> (import mod-synlist)
> (syntax->list (syntax (foo bar baz)))
(#3(syntax-object
foo
((top) #4(ribcage (#2(import-token *top*)) ())))
#3(syntax-object
bar
((top) #4(ribcage (#2(import-token *top*)) ())))
#3(syntax-object
baz
((top) #4(ribcage (#2(import-token *top*)) ()))))
> ^D
So the cause for the above error has to be elsewhere - but where?
Please help,
Regards and thanks in advance,
Johannes Br=FCgmann
The files used in the above session:
[1] test.scm:
(require-library 'sisc/libs/srfi/srfi-1)
(require-library 'sisc/libs/srfi/srfi-14)
(require-library 'sisc/libs/srfi/srfi-23)
(require-library 'sisc/libs/srfi/srfi-28)
(require-library 'sisc/scsh-regexp/scsh-regexp)
(import srfi-1)
(import srfi-14)
(import srfi-23)
(import srfi-28)
(import scsh-regexp/scsh-regexp)
(load "awk.scm")
(define awk-result
(call-with-values (lambda () =
(call-with-input-file "test.txt"
(lambda (inp)
(awk (read-line inp #t)
(line)
lineno
=
((lines-taken 0)
(lines-dropped 0)
(result '()))
=
continue
=
((eof-object? line) (continue lines-taken lines-dropped result))
=
(2 (continue lines-taken (+ lines-dropped 1) result))
=
("^\([^;]+\);\([^;]+\);\(.*\)$"
=3D> (lambda (m)
(let ((num (regexp-substitute #f m 'pre 1 'post))
(col1 (regexp-substitute #f m 'pre 2 'post))
(col2 (regexp-substitute #f m 'pre 3 'post)))
(continue (+ lines-taken 1) lines-dropped (cons (list num col1 c=
ol2) result)))))
=
(else (error "file format not supported in line number ~a" lineno=
))))))
(lambda (lines-taken lines-dropped result)
(display (format "lines-taken: ~a" lines-taken)) (newline)
(display (format "lines-dropped: ~a" lines-dropped)) (newline)
(reverse result))))
[2] test.txt:
1;col1;col2
2;hello;world
3;good;bye
[3] awk.scm:
;;; awk.scm - provide awk-like macro
;;; all stuff in this file is shamelessly stolen from mzscheme/mzlib/awk.ss
;;;@args : char -> bool
;;;predicate for newline
(define (newline? char)
(and (char-set-contains? char-set:whitespace char)
(not (char-set-contains? char-set:blank char))))
;;;@args : port -> string
;;;reads @var{port} until newline
(define (read-line port . maybe-drop-newline?)
(let ((drop-newline? (if (null? maybe-drop-newline?) #f (car maybe-drop-n=
ewline?))))
(let loop ((chars '()))
(let ((c (peek-char port)))
(if (and (null? chars) (eof-object? c))
c
(let ((next-chars (if (eof-object? c) =
chars =
(if (and (newline? (read-char port)) drop-newline?)
chars =
(cons c chars)))))
(if (or (eof-object? c) (newline? c))
(list->string (reverse next-chars))
(loop next-chars))))))))
;;;@args : delim -> string -> list of fields
;;;create an infix field splitter
(define (make-infix-field-splitter delim)
(let ((rx (posix-string->regexp (format "[^~a]+" delim))))
(lambda (string)
(regexp-fold-right rx =
(lambda (m nm res)
(cons (match:substring m 0) res))
'() string))))
(define regexp posix-string->regexp)
(define (regexp-exec re s)
(let ((rx (if (string? re) (posix-string->regexp re) re)))
(let ((m (regexp-search rx s)))
m)))
(define (regexp-match re s)
(let ((rx (if (string? re) (posix-string->regexp re) re)))
(let ((m (regexp-search rx s)))
m)))
;;; from Chez Scheme, K. Dybvig, syntax-case
(define syntax->list
(lambda (ls)
(syntax-case ls ()
(() '())
((x . r) (cons (syntax x) (syntax->list (syntax r)))))))
;; a syntax null?
(define (stx-null? p)
(or (null? p)
(null? (syntax-object->datum p))))
(define (raise-syntax-error=A0name message-string=A0expr sub-expr)
(error (string-append name ": " message-string ": " expr ": " sub-expr)))
;;;@ (AWK <.next-record.> <.record&field-vars.> [<.counter.>] <.state-var-d=
ecls.> <.clause[1].> ...)
;;;provide loop macro with awk facility, see SCSH-Manual, Chapter 8
(define-syntax awk
(lambda (stx)
(syntax-case stx ()
((_ next-record (record field ...) counter ((state-variable init-expr=
) ...) continue clause ...)
(and (identifier? (syntax counter)) (identifier? (syntax continue)))
(let ((clauses (syntax->list (syntax (clause ...))))
(initvars '()))
(with-syntax (((local-state ...) (generate-temporaries (syntax->li=
st (syntax (state-variable ...))))))
(letrec ((get-after-clauses (lambda ()
(let loop ((l clauses) (afters '()))
(cond
((null? l) (if (stx-null? afters)
(syntax ((values state-variable ...)))
afters))
((syntax-case (car l) (after) ((after . rest) (syntax rest)) (_els=
e #f))
=3D> (lambda (rest)
(with-syntax (((after ...) afters))
(loop (cdr l) (syntax (after ... . rest))))))
(else (loop (cdr l) afters))))))
(wrap-state (lambda (e)
(syntax-case e (=3D>) =
((=3D> f) (with-syntax ((body (wrap-state (syntax ((f arg))))))
(syntax (=3D> (lambda (arg) . body)))))
(body (syntax ((call-with-values (lambda () . body)
(lambda (local-state ... . extras)
(set! else-ready? #f)
(set! state-variable local-state)
...))))))))
(make-range (lambda (include-on? include-off? body rest)
(syntax-case body ()
((t1 t2 . body)
(with-syntax ((on? (car (generate-temporaries '(1))))
(t1 (make-test (syntax-object->datum (syntax t1)) (syntax t1)))
(t2 (make-test (syntax-object->datum (syntax t2)) (syntax t2)))
(body (wrap-state (syntax body))))
(with-syntax ((check (if include-on?
(if include-off?
(syntax post-on-on?)
(syntax on?))
(if include-off?
(syntax orig-on?)
(syntax (and orig-on? on?))))))
(set! initvars (cons (syntax (on? #f)) initvars))
(syntax ((let ((orig-on? on?))
(unless on? (set! on? t1))
(let ((post-on-on? on?))
(when on? (set! on? (not t2))))
(when check . body)) . rest)))))
(_else (raise-syntax-error #f "bad range" stx body)))))
(make-test (lambda (test expr)
(cond
((string? test)
(with-syntax ((g (car (generate-temporaries '(1))))
(expr expr))
(set! initvars (cons (syntax (g (regexp expr))) initvars))
(syntax (regexp-exec expr record))))
((number? test)
(with-syntax ((expr expr))
(syntax (=3D expr counter))))
(else expr))))
(get-testing-clauses =
(lambda ()
(let loop ((l clauses))
(if (null? l)
'()
(syntax-case (car l) ()
((test-expr body ...)
(with-syntax ((rest (loop (cdr l))))
(let ((test (syntax-object->datum (syntax test-expr)))
(body (syntax (body ...))))
(cond
((or (string? test) (number? test))
(with-syntax ((t (make-test test (syntax test-expr)))
(body (wrap-state body)))
(syntax ((cond (t . body) (else (void))) . rest))))
((eq? test 'else)
(with-syntax ((body (wrap-state body)))
(syntax ((when else-ready? . body) (set! else-ready? #t) . rest))))
((eq? test 'range) =
(make-range #f #f body (syntax rest)))
((eq? test ':range)
(make-range #t #f body (syntax rest)))
((eq? test 'range:)
(make-range #f #t body (syntax rest)))
((eq? test ':range:)
(make-range #t #t body (syntax rest)))
((eq? test 'after) =
(syntax rest))
((eq? test '/)
(with-syntax ((g (car (generate-temporaries '(1)))))
; PLT used syntax-case* at this place (syntax-case* takes a comparison=
-procedure after the literals
; to compare literals with their po=
tential matches in clauses
(syntax-case body (/) =
((re / (var ...) . body)
(and ;((lambda (a b) (eq? (syntax-object->datum a) (syntax-obj=
ect->datum b))) (syntax /) (syntax slash))
(string? (syntax-object->datum (syntax re)))
(andmap (lambda (x) (or (identifier? x) (not (syntax-object->dat=
um x))))
(syntax->list (syntax (var ...)))))
(with-syntax (((var ...) (map (lambda (x)
(if (identifier? x)
x
(car (generate-temporaries '(1)))))
(syntax->list (syntax (var ...)))))
(body (wrap-state (syntax body))))
(set! initvars (cons (syntax (g (regexp re))) initvars))
(syntax ((cond
((regexp-match re record) =3D> (lambda (arg)
(apply (lambda (var ...) . body) arg)))
(else (void)))
. rest))))
(_else (raise-syntax-error #f "bad / ... / clause" stx (car l))=
))))
(else (with-syntax ((body (wrap-state body)))
(syntax ((cond =
(test-expr . body)
(else (void))) . rest))))))))
(_else (raise-syntax-error #f "bad clause" stx (car l)))))))))
(with-syntax ((testing-clauses (get-testing-clauses))
(after-clauses (get-after-clauses))
(initvars initvars))
(syntax (let ((state-variable init-expr) ... . initvars)
(let loop ((counter 1)) =
(call-with-values (lambda () next-record)
(lambda (record field ...)
(if (eof-object? record)
(begin . after-clauses)
(let ((else-ready? #t))
(call-with-current-continuation =
(lambda (escape)
(let ((continue (lambda (local-state ... . extras)
(set! state-variable local-state)
...
(escape))))
. testing-clauses)))
(loop (add1 counter))))))))))))))
;; Left out continue...
((_ next-record (record field-variable ...) counter-variable ((state-=
variable init-expr) ...) clause ...)
(identifier? (syntax counter-variable))
(syntax (awk next-record (record field-variable ...) counter-variabl=
e ((state-variable init-expr) ...) continue clause ...)))
;; Left out counter...
((_ next-record (record field-variable ...) ((state-variable init-exp=
r) ...) continue-variable clause ...)
(identifier? (syntax continue-variable))
(syntax (awk next-record (record field-variable ...) counter ((state=
-variable init-expr) ...) continue-variable clause ...)))
;; Left out both...
((_ next-record (record field-variable ...) ((state-variable init-exp=
r) ...) clause ...)
(syntax (awk next-record (record field-variable ...) counter ((state=
-variable init-expr) ...) continue clause ...))))))
[4] mod-awk.scm:
(require-library 'sisc/libs/srfi/srfi-1)
(require-library 'sisc/libs/srfi/srfi-14)
(require-library 'sisc/libs/srfi/srfi-23)
(require-library 'sisc/libs/srfi/srfi-28)
(require-library 'sisc/scsh-regexp/scsh-regexp)
(module awk
(make-infix-field-splitter newline? read-line regexp regexp-match regex=
p-exec (awk))
(import srfi-1)
(import srfi-14)
(import srfi-23)
(import srfi-28)
(import scsh-regexp/scsh-regexp)
(include "awk.scm")
)
[5] mod-synlist.scm:
(module mod-synlist
((syntax->list))
(include "synlist.scm"))
[6] synlist.scm:
(define syntax->list
(lambda (ls)
(syntax-case ls ()
(() '())
((x . r) (cons (syntax x) (syntax->list (syntax r)))))))
-- =
F=FCr uns gibt es doch nur einen Gott, den Vater, von dem alle Dinge=
sind
und wir f=FCr ihn; und einen Herrn, Jesus Christus, durch den alle =
Dinge
sind, und wir durch ihn.
1. Korinther 8, 6
-------------------------------------------------------------------------
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/