From 131826039c62bdfd5932272b5d19d4b08cbe4e63 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Apr 2009 13:54:38 +0200 Subject: [PATCH] syncase early in boot-9, defmacros in terms of syntax-case -- halfway working * module/ice-9/boot-9.scm (eval-when): Remove, as syncase is going to handle this one for us. (sc-expand, sc-expand3, sc-chi, install-global-transformer) (syntax-dispatch, syntax-error, annotation?, bound-identifier=?) (datum->syntax-object, free-identifier=?, generate-temporaries) (identifier?, syntax-object->datum, void, andmap): Oh, ugly of uglies: add these exciting definitions to the main environment. Hopefully we can pull them back out soon. (make-module-ref, resolve-module): Stub these out, as a replacement for expand-support. (%pre-modules-transformer): Define to sc-expand, so that we are using syncase from the very start. (defmacro, define-macro): Define in terms of syntax-case. (macroexpand, macroexpand-1): Remove, there should be a different way to get at this -- though perhaps with the same name. (make-module): Make sc-expand the default module-transformer. (process-define-module): Issue a deprecation warning when using ice-9 syncase. (primitive-macro?): Remove, no meaning... (use-syntax): Deprecate. (define-private, define-public, defmacro-public): Rework in terms of syntax-rules. * module/ice-9/syncase.scm: Gut, as syncase is provided by core now. --- module/ice-9/boot-9.scm | 274 ++++++++++++++++++--------------------- module/ice-9/syncase.scm | 200 ++-------------------------- 2 files changed, 135 insertions(+), 339 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5e658663e..923c042ff 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -131,30 +131,63 @@ '(guile)) (define (module-add! module sym var) (hashq-set! (%get-pre-modules-obarray) sym var)) +(define sc-macro 'sc-macro) +(define (make-module-ref mod var public?) + (cond + ((or (not mod) + (eq? mod (module-name (current-module))) + (and (not public?) + (not (module-variable (resolve-module mod) var)))) + var) + (else + (list (if public? '@ '@@) mod var)))) +(define (resolve-module . args) + #f) -;; (eval-when (situation...) form...) -;; -;; Evaluate certain code based on the situation that eval-when is used -;; in. There are three situations defined. -;; -;; `load' triggers when a file is loaded via `load', or when a compiled -;; file is loaded. -;; -;; `compile' triggers when an expression is compiled. -;; -;; `eval' triggers when code is evaluated interactively, as at the REPL -;; or via the `compile' or `eval' procedures. +(define sc-expand #f) +(define sc-expand3 #f) +(define sc-chi #f) +(define install-global-transformer #f) +(define syntax-dispatch #f) +(define syntax-error #f) +(define (annotation? x) #f) -;; NB: this macro is only ever expanded by the interpreter. The compiler -;; notices it and interprets the situations differently. -(define eval-when - (procedure->memoizing-macro - (lambda (exp env) - (let ((situations (cadr exp)) - (body (cddr exp))) - (if (or (memq 'load situations) - (memq 'eval situations)) - `(begin . ,body)))))) +(define bound-identifier=? #f) +(define datum->syntax-object #f) +(define free-identifier=? #f) +(define generate-temporaries #f) +(define identifier? #f) +(define syntax-object->datum #f) + +(define (void) (if #f #f)) + +(define andmap + (lambda (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 (syncase-error who format-string why what) + (%start-stack 'syncase-stack + (lambda () + (scm-error 'misc-error who "~A ~S" (list why what) '())))) + +;; Until the module system is booted, this will be the current expander. +(primitive-load-path "ice-9/psyntax-pp") + +(define %pre-modules-transformer (lambda args (pk 'in args 'out (apply sc-expand args)))) @@ -170,54 +203,23 @@ ;;; Depends on: features, eval-case ;;; -(define macro-table (make-weak-key-hash-table 61)) -(define xformer-table (make-weak-key-hash-table 61)) +(define-syntax define-macro + (lambda (x) + (syntax-case x () + ((_ (macro . args) . body) + (syntax (define-macro macro (lambda args . body)))) + ((_ macro transformer) + (syntax + (define-syntax macro + (lambda (y) + (let ((v (syntax-object->datum y))) + (datum->syntax-object y (apply transformer (cdr v))))))))))) -(define (defmacro? m) (hashq-ref macro-table m)) -(define (assert-defmacro?! m) (hashq-set! macro-table m #t)) -(define (defmacro-transformer m) (hashq-ref xformer-table m)) -(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t)) - -(define defmacro:transformer - (lambda (f) - (let* ((xform (lambda (exp env) - (copy-tree (apply f (cdr exp))))) - (a (procedure->memoizing-macro xform))) - (assert-defmacro?! a) - (set-defmacro-transformer! a f) - a))) - - -(define defmacro - (let ((defmacro-transformer - (lambda (name parms . body) - (let ((transformer `(lambda ,parms ,@body))) - `(eval-when - (eval load compile) - (define ,name (defmacro:transformer ,transformer))))))) - (defmacro:transformer defmacro-transformer))) - - -;; XXX - should the definition of the car really be looked up in the -;; current module? - -(define (macroexpand-1 e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (local-ref (list a))))) - (if (defmacro? val) - (apply (defmacro-transformer val) (cdr e)) - e))) - (#t e))) - -(define (macroexpand e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (local-ref (list a))))) - (if (defmacro? val) - (macroexpand (apply (defmacro-transformer val) (cdr e))) - e))) - (#t e))) +(define-syntax defmacro + (lambda (x) + (syntax-case x () + ((_ macro args . body) + (syntax (define-macro macro (lambda args . body))))))) (provide 'defmacro) @@ -1196,7 +1198,8 @@ "Lazy-binder expected to be a procedure or #f." binder)) (let ((module (module-constructor (make-hash-table size) - uses binder #f #f #f #f #f + uses binder #f %pre-modules-transformer + #f #f #f (make-hash-table %default-import-size) '() (make-weak-key-hash-table 31)))) @@ -1837,6 +1840,7 @@ already) (autoload ;; Try to autoload the module, and recurse. + (pk name) (try-load-module name) (resolve-module name #f)) (else @@ -2006,23 +2010,34 @@ ((#:use-module #:use-syntax) (or (pair? (cdr kws)) (unrecognized kws)) - (let* ((interface-args (cadr kws)) - (interface (apply resolve-interface interface-args))) - (and (eq? (car kws) #:use-syntax) - (or (symbol? (caar interface-args)) - (error "invalid module name for use-syntax" - (car interface-args))) - (set-module-transformer! - module - (module-ref interface - (car (last-pair (car interface-args))) - #f))) + (cond + ((equal? (caadr kws) '(ice-9 syncase)) + (issue-deprecation-warning + "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.") (loop (cddr kws) - (cons interface reversed-interfaces) + reversed-interfaces exports re-exports replacements - autoloads))) + autoloads)) + (else + (let* ((interface-args (cadr kws)) + (interface (apply resolve-interface interface-args))) + (and (eq? (car kws) #:use-syntax) + (or (symbol? (caar interface-args)) + (error "invalid module name for use-syntax" + (car interface-args))) + (set-module-transformer! + module + (module-ref interface + (car (last-pair (car interface-args))) + #f))) + (loop (cddr kws) + (cons interface reversed-interfaces) + exports + re-exports + replacements + autoloads))))) ((#:autoload) (or (and (pair? (cdr kws)) (pair? (cddr kws))) (unrecognized kws)) @@ -2678,32 +2693,6 @@ module '(ice-9 q) '(make-q q-length))}." `(with-fluids* (list ,@fluids) (list ,@values) (lambda () ,@body))))) - - -;;; {Macros} -;;; - -;; actually....hobbit might be able to hack these with a little -;; coaxing -;; - -(define (primitive-macro? m) - (and (macro? m) - (not (macro-transformer m)))) - -(defmacro define-macro (first . rest) - (let ((name (if (symbol? first) first (car first))) - (transformer - (if (symbol? first) - (car rest) - `(lambda ,(cdr first) ,@rest)))) - `(eval-when - (eval load compile) - (define ,name (defmacro:transformer ,transformer))))) - - - - ;;; {While} ;;; ;;; with `continue' and `break'. @@ -2843,50 +2832,33 @@ module '(ice-9 q) '(make-q q-length))}." (defmacro use-syntax (spec) `(eval-when (eval load compile) - ,@(if (pair? spec) - `((process-use-modules (list - (list ,@(compile-interface-spec spec)))) - (set-module-transformer! (current-module) - ,(car (last-pair spec)))) - `((set-module-transformer! (current-module) ,spec))) - *unspecified*)) + (issue-deprecation-warning + "`use-syntax' is deprecated. Please contact guile-devel for more info.") + (process-use-modules (list (list ,@(compile-interface-spec spec)))) + *unspecified*)) ;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed ;; as soon as guile supports hygienic macros. -(define define-private define) +(define-syntax define-private + (syntax-rules () + ((_ foo bar) + (define foo bar)))) -(defmacro define-public args - (define (syntax) - (error "bad syntax" (list 'define-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - ((pair? n) (defined-name (car n))) - (else (syntax)))) - (cond - ((null? args) - (syntax)) - (#t - (let ((name (defined-name (car args)))) - `(begin - (define-private ,@args) - (export ,name)))))) +(define-syntax define-public + (syntax-rules () + ((_ (name . args) . body) + (define-public name (lambda args . body))) + ((_ name val) + (begin + (define name val) + (export name))))) -(defmacro defmacro-public args - (define (syntax) - (error "bad syntax" (list 'defmacro-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - (else (syntax)))) - (cond - ((null? args) - (syntax)) - (#t - (let ((name (defined-name (car args)))) - `(begin - (export-syntax ,name) - (defmacro ,@args)))))) +(define-syntax defmacro-public + (syntax-rules () + ((_ name args . body) + (begin + (defmacro name args . body) + (export-syntax name))))) ;; Export a local variable @@ -3375,6 +3347,12 @@ module '(ice-9 q) '(make-q q-length))}." ;;; Place the user in the guile-user module. ;;; +;;; FIXME: annotate ? +;; (define (syncase exp) +;; (with-fluids ((expansion-eval-closure +;; (module-eval-closure (current-module)))) +;; (deannotate/source-properties (sc-expand (annotate exp))))) + (define-module (guile-user)) ;;; boot-9.scm ends here diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index d8fdeb4c9..22391a8c8 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -17,197 +17,15 @@ (define-module (ice-9 syncase) - :use-module (ice-9 expand-support) - :use-module (ice-9 debug) - :use-module (ice-9 threads) - :export-syntax (sc-macro define-syntax define-syntax-public - fluid-let-syntax - identifier-syntax let-syntax - letrec-syntax syntax syntax-case syntax-rules - with-syntax - include) - :export (sc-expand sc-expand3 install-global-transformer - syntax-dispatch syntax-error bound-identifier=? - datum->syntax-object free-identifier=? - generate-temporaries identifier? syntax-object->datum - void syncase) - :replace (eval eval-when)) + ) - - -(define (annotation? x) #f) - -(define sc-macro - (procedure->memoizing-macro - (lambda (exp env) - (save-module-excursion - (lambda () - ;; Because memoization happens lazily, env's module isn't - ;; necessarily the current module. - (set-current-module (eval-closure-module (car (last-pair env)))) - (strip-expansion-structures (sc-expand exp))))))) - -;;; Exported variables - -(define sc-expand #f) -(define sc-expand3 #f) -(define sc-chi #f) -(define install-global-transformer #f) -(define syntax-dispatch #f) -(define syntax-error #f) - -(define bound-identifier=? #f) -(define datum->syntax-object #f) -(define free-identifier=? #f) -(define generate-temporaries #f) -(define identifier? #f) -(define syntax-object->datum #f) - -(define primitive-syntax '(quote lambda letrec if set! begin define or - and let let* cond do quasiquote unquote - unquote-splicing case @ @@)) - -(for-each (lambda (symbol) - (set-symbol-property! symbol 'primitive-syntax #t)) - primitive-syntax) - -;;; Hooks needed by the syntax-case macro package - -(define (void) *unspecified*) - -(define andmap - (lambda (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 (error who format-string why what) - (start-stack 'syncase-stack - (scm-error 'misc-error - who - "~A ~S" - (list why what) - '()))) - -(define the-syncase-module (current-module)) - -(define guile-macro - (cons 'external-macro - (lambda (e r w s mod) - (let ((e (syntax-object->datum e))) - (if (symbol? e) - ;; pass the expression through - e - (let* ((mod (resolve-module mod)) - (m (module-ref mod (car e)))) - (if (eq? (macro-type m) 'syntax) - ;; pass the expression through - e - ;; perform Guile macro transform - (let ((e ((macro-transformer m) - (strip-expansion-structures e) - (append r (list (module-eval-closure mod)))))) - (if (variable? e) - e - (if (null? r) - (sc-expand e) - (sc-chi e r w (module-name mod)))))))))))) - -(define generated-symbols (make-weak-key-hash-table 1019)) - -;; We define our own gensym here because the Guile built-in one will -;; eventually produce uninterned and unreadable symbols (as needed for -;; safe macro expansions) and will the be inappropriate for dumping to -;; pssyntax.pp. -;; -;; syncase is supposed to only require that gensym produce unique -;; readable symbols, and they only need be unique with respect to -;; multiple calls to gensym, not globally unique. -;; -(define gensym - (let ((counter 0)) - - (define next-id - (if (provided? 'threads) - (let ((symlock (make-mutex))) - (lambda () - (let ((result #f)) - (with-mutex symlock - (set! result counter) - (set! counter (+ counter 1))) - result))) - ;; faster, non-threaded case. - (lambda () - (let ((result counter)) - (set! counter (+ counter 1)) - result)))) - - ;; actual gensym body code. - (lambda (. rest) - (let* ((next-val (next-id)) - (valstr (number->string next-val))) - (cond - ((null? rest) - (string->symbol (string-append "syntmp-" valstr))) - ((null? (cdr rest)) - (string->symbol (string-append "syntmp-" (car rest) "-" valstr))) - (else - (error - (string-append - "syncase's gensym expected 0 or 1 arguments, got " - (length rest))))))))) - -;;; Load the preprocessed code - -(let ((old-debug #f) - (old-read #f)) - (dynamic-wind (lambda () - (set! old-debug (debug-options)) - (set! old-read (read-options))) - (lambda () - (debug-disable 'debug 'procnames) - (read-disable 'positions) - (load-from-path "ice-9/psyntax-pp")) - (lambda () - (debug-options old-debug) - (read-options old-read)))) - -(define internal-eval (nested-ref the-scm-module '(%app modules guile eval))) - -(define (eval x environment) - (internal-eval (if (and (pair? x) - (equal? (car x) "noexpand")) - (strip-expansion-structures (cadr x)) - (strip-expansion-structures (sc-expand x))) - environment)) +(issue-deprecation-warning + "Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary.") ;;; Hack to make syncase macros work in the slib module -(let ((m (nested-ref the-root-module '(%app modules ice-9 slib)))) - (if m - (set-object-property! (module-local-variable m 'define) - '*sc-expander* - '(define)))) - -(define (syncase exp) - (strip-expansion-structures (sc-expand exp))) - -(set-module-transformer! the-syncase-module syncase) - -(define-syntax define-syntax-public - (syntax-rules () - ((_ name rules ...) - (begin - ;(eval-case ((load-toplevel) (export-syntax name))) - (define-syntax name rules ...))))) +;; FIXME wingo is this still necessary? +;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib)))) +;; (if m +;; (set-object-property! (module-local-variable m 'define) +;; '*sc-expander* +;; '(define))))