Re: syntax-case in the repl and in the module system

Hello,

"Scott G. Miller" <[email protected]> writes:

> On Mon, May 19, 2008 at 11:29 AM, Johannes Bruegmann
> <[email protected]> wrote:
>>
> Psyntax is a bit picky about the way modules reference defined
> bindings in their own definitions.  It behaves like letrec, where
> right hand sides can't reference any other letrec binding at
> definition time.  In awk.scm, this happens when it expands the syntax
> definitions in the awk macro.  The easiest workaround is to make the
> dependent functions of the awk macro internal definitions, eg:
>
> (define-syntax awk
>   (lambda (stx)
>     (define (syntax->list ...
>
> etc
>
> Hope that works,

It worked, yes! And now i know where to read on regarding psyntax!


Thanks a lot,
Johannes

The working awk.scm now looks like this (in case anybody else ever
will be interested in):

;;; awk.scm - provide awk-like macro

;;; the awk macro and its dependencies in this file are from mzscheme/mzlib=
/awk.ss
;;; syntax->list is from ChezScheme

;;;@chapter Module @code{awk}
;;;@section Imports/Exports in SISC
;;;@lisp
;;; (module awk
;;;     (make-infix-field-splitter newline? read-line regexp regexp-match r=
egexp-exec (awk))
;;; =

;;;   (import srfi-1)
;;;   (import srfi-14)
;;;   (import srfi-23)
;;;   (import srfi-28)
;;;   (import scsh-regexp/scsh-regexp)
;;; =

;;;   (include "awk.scm")
;;; =

;;; )
;;;@end lisp
;;;@section Description
;;;provide awk-like macro (as introduced by Olin Shivers in Scsh-Manual, Ch=
apter 8) for SISC

;;;@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)))

;;;@ (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)
    ;; 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-exp=
r)))

    (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 ...))))))

-- =

       Wo  sind  denn  deine  G=F6tter, die du dir gemacht hast? Sie sollen=
 sich
       aufmachen, wenn sie dich retten k=F6nnen zur Zeit deines Ungl=FCcks!

                                                    Jeremia 2, 28

-------------------------------------------------------------------------
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/