mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

syncase early in boot-9, defmacros in terms of syntax-case -- halfway working

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-04-24 13:54:38 +02:00
parent a26934a850
commit 131826039c
2 changed files with 135 additions and 339 deletions
Download patch file Download diff file Expand all files Collapse all files

248
module/ice-9/boot-9.scm
View file

@ -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,6 +2010,17 @@
((#:use-module #:use-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
(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)
reversed-interfaces
exports
re-exports
replacements
autoloads))
(else
(let* ((interface-args (cadr kws))
(interface (apply resolve-interface interface-args)))
(and (eq? (car kws) #:use-syntax)
@ -2022,7 +2037,7 @@
exports
re-exports
replacements
autoloads)))
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)))
(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

200
module/ice-9/syncase.scm
View file

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