mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
Replace eval-case with eval-when
* module/ice-9/boot-9.scm (eval-when): Replace eval-case with eval-when. Eval-when is *much* simpler, and more expressive to boot. Perhaps in the future we'll get 'visit and 'revisit too. * module/ice-9/deprecated.scm (eval-case): Provide mostly-working deprecated version of eval-case. * module/ice-9/boot-9.scm (defmacro, define-macro): Relax condition: we can make defmacros that are not at the toplevel now. But in the future we should replace this implementation of defmacros with one written in syntax-case. (define-module, use-modules, use-syntax): Allow at non-toplevel. (define-public, defmacro-public, export, re-export): Don't evaluate at compile-time, I can't see how that helps things. Allow `export' and `re-export' at non-toplevel. * module/ice-9/getopt-long.scm: * module/ice-9/i18n.scm: * module/oop/goops.scm: * module/oop/goops/compile.scm: * module/oop/goops/dispatch.scm: Switch to use eval-when, not eval-case. * module/language/scheme/compile-ghil.scm (eval-when): Replace eval-case transformer with eval-when transformer. Sooooo much simpler, and it will get better once we separate expansion from compilation. * module/language/scheme/expand.scm (quasiquote): Hm, expand quasiquote properly. Not hygienic. Syncase needed. (lambda): Handle internal defines with docstrings propertly.
This commit is contained in:
Andy Wingo
parent
07e01c4cf9
commit
b15dea6857
9 changed files with 104 additions and 147 deletions
|
|
@ -86,42 +86,29 @@
|
|||
|
||||
|
||||
|
||||
;;; {EVAL-CASE}
|
||||
;;;
|
||||
|
||||
;; (eval-case ((situation*) forms)* (else forms)?)
|
||||
;; (eval-when (situation...) form...)
|
||||
;;
|
||||
;; Evaluate certain code based on the situation that eval-case is used
|
||||
;; in. There are three situations defined. `load-toplevel' triggers for
|
||||
;; code evaluated at the top-level, for example from the REPL or when
|
||||
;; loading a file. `compile-toplevel' triggers for code compiled at the
|
||||
;; toplevel. `execute' triggers during execution of code not at the top
|
||||
;; level.
|
||||
;; 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 eval-case
|
||||
;; 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)
|
||||
(define (toplevel-env? env)
|
||||
(or (not (pair? env)) (not (pair? (car env)))))
|
||||
(define (syntax)
|
||||
(error "syntax error in eval-case"))
|
||||
(let loop ((clauses (cdr exp)))
|
||||
(cond
|
||||
((null? clauses)
|
||||
#f)
|
||||
((not (list? (car clauses)))
|
||||
(syntax))
|
||||
((eq? 'else (caar clauses))
|
||||
(or (null? (cdr clauses))
|
||||
(syntax))
|
||||
(cons 'begin (cdar clauses)))
|
||||
((not (list? (caar clauses)))
|
||||
(syntax))
|
||||
((and (toplevel-env? env)
|
||||
(memq 'load-toplevel (caar clauses)))
|
||||
(cons 'begin (cdar clauses)))
|
||||
(else
|
||||
(loop (cdr clauses))))))))
|
||||
(let ((situations (cadr exp))
|
||||
(body (cddr exp)))
|
||||
(if (or (memq 'load situations)
|
||||
(memq 'eval situations))
|
||||
`(begin . ,body))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -129,8 +116,8 @@
|
|||
;; module, the primary location of those symbols, rather than in
|
||||
;; (guile-user), the default module that we compile in.
|
||||
|
||||
(eval-case
|
||||
((compile-toplevel)
|
||||
(eval-when
|
||||
((compile)
|
||||
(set-current-module (resolve-module '(guile)))))
|
||||
|
||||
;;; {Defmacros}
|
||||
|
|
@ -160,11 +147,9 @@
|
|||
(let ((defmacro-transformer
|
||||
(lambda (name parms . body)
|
||||
(let ((transformer `(lambda ,parms ,@body)))
|
||||
`(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(define ,name (defmacro:transformer ,transformer)))
|
||||
(else
|
||||
(error "defmacro can only be used at the top level")))))))
|
||||
`(eval-when
|
||||
(eval load compile)
|
||||
(define ,name (defmacro:transformer ,transformer)))))))
|
||||
(defmacro:transformer defmacro-transformer)))
|
||||
|
||||
|
||||
|
|
@ -2707,11 +2692,9 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
(if (symbol? first)
|
||||
(car rest)
|
||||
`(lambda ,(cdr first) ,@rest))))
|
||||
`(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(define ,name (defmacro:transformer ,transformer)))
|
||||
(else
|
||||
(error "define-macro can only be used at the top level")))))
|
||||
`(eval-when
|
||||
(eval load compile)
|
||||
(define ,name (defmacro:transformer ,transformer)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -2753,8 +2736,8 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
;; Return a list of expressions that evaluate to the appropriate
|
||||
;; arguments for resolve-interface according to SPEC.
|
||||
|
||||
(eval-case
|
||||
((compile-toplevel)
|
||||
(eval-when
|
||||
((compile)
|
||||
(if (memq 'prefix (read-options))
|
||||
(error "boot-9 must be compiled with #:kw, not :kw"))))
|
||||
|
||||
|
|
@ -2821,14 +2804,12 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
(cddr args))))))
|
||||
|
||||
(defmacro define-module args
|
||||
`(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(let ((m (process-define-module
|
||||
(list ,@(compile-define-module-args args)))))
|
||||
(set-current-module m)
|
||||
m))
|
||||
(else
|
||||
(error "define-module can only be used at the top level"))))
|
||||
`(eval-when
|
||||
(eval load compile)
|
||||
(let ((m (process-define-module
|
||||
(list ,@(compile-define-module-args args)))))
|
||||
(set-current-module m)
|
||||
m)))
|
||||
|
||||
;; The guts of the use-modules macro. Add the interfaces of the named
|
||||
;; modules to the use-list of the current module, in order.
|
||||
|
|
@ -2846,28 +2827,24 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
(module-use-interfaces! (current-module) interfaces)))))
|
||||
|
||||
(defmacro use-modules modules
|
||||
`(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(process-use-modules
|
||||
(list ,@(map (lambda (m)
|
||||
`(list ,@(compile-interface-spec m)))
|
||||
modules)))
|
||||
*unspecified*)
|
||||
(else
|
||||
(error "use-modules can only be used at the top level"))))
|
||||
`(eval-when
|
||||
(eval load compile)
|
||||
(process-use-modules
|
||||
(list ,@(map (lambda (m)
|
||||
`(list ,@(compile-interface-spec m)))
|
||||
modules)))
|
||||
*unspecified*))
|
||||
|
||||
(defmacro use-syntax (spec)
|
||||
`(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
`(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*)
|
||||
(else
|
||||
(error "use-syntax can only be used at the top level"))))
|
||||
*unspecified*))
|
||||
|
||||
;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
|
||||
;; as soon as guile supports hygienic macros.
|
||||
|
|
@ -2888,7 +2865,7 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
(let ((name (defined-name (car args))))
|
||||
`(begin
|
||||
(define-private ,@args)
|
||||
(eval-case ((load-toplevel compile-toplevel) (export ,name))))))))
|
||||
(export ,name))))))
|
||||
|
||||
(defmacro defmacro-public args
|
||||
(define (syntax)
|
||||
|
|
@ -2903,7 +2880,7 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
(#t
|
||||
(let ((name (defined-name (car args))))
|
||||
`(begin
|
||||
(eval-case ((load-toplevel compile-toplevel) (export-syntax ,name)))
|
||||
(export-syntax ,name)
|
||||
(defmacro ,@args))))))
|
||||
|
||||
;; Export a local variable
|
||||
|
|
@ -2941,22 +2918,14 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
names)))
|
||||
|
||||
(defmacro export names
|
||||
`(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(call-with-deferred-observers
|
||||
(lambda ()
|
||||
(module-export! (current-module) ',names))))
|
||||
(else
|
||||
(error "export can only be used at the top level"))))
|
||||
`(call-with-deferred-observers
|
||||
(lambda ()
|
||||
(module-export! (current-module) ',names))))
|
||||
|
||||
(defmacro re-export names
|
||||
`(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(call-with-deferred-observers
|
||||
(lambda ()
|
||||
(module-re-export! (current-module) ',names))))
|
||||
(else
|
||||
(error "re-export can only be used at the top level"))))
|
||||
`(call-with-deferred-observers
|
||||
(lambda ()
|
||||
(module-re-export! (current-module) ',names))))
|
||||
|
||||
(defmacro export-syntax names
|
||||
`(export ,@names))
|
||||
|
|
|
|||
|
|
@ -178,3 +178,20 @@
|
|||
|
||||
(define (list->uniform-vector prot lst)
|
||||
(list->uniform-array 1 prot lst))
|
||||
|
||||
(define-macro (eval-case . clauses)
|
||||
(issue-deprecation-warning
|
||||
"`eval-case' is deprecated. Use `eval-when' instead.")
|
||||
;; Practically speaking, eval-case only had load-toplevel and else as
|
||||
;; conditions.
|
||||
(cond
|
||||
((assoc-ref clauses '(load-toplevel))
|
||||
=> (lambda (exps)
|
||||
;; the *unspecified so that non-toplevel definitions will be
|
||||
;; caught
|
||||
`(begin *unspecified* . ,exps)))
|
||||
((assoc-ref clauses 'else)
|
||||
=> (lambda (exps)
|
||||
`(begin *unspecified* . ,exps)))
|
||||
(else
|
||||
`(begin))))
|
||||
|
|
|
|||
|
|
@ -160,34 +160,29 @@
|
|||
:use-module ((ice-9 common-list) :select (some remove-if-not))
|
||||
:export (getopt-long option-ref))
|
||||
|
||||
(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
|
||||
(eval-when (eval load compile)
|
||||
;; This binding is used both at compile-time and run-time.
|
||||
|
||||
(define option-spec-fields '(name
|
||||
value
|
||||
required?
|
||||
single-char
|
||||
predicate
|
||||
value-policy))))
|
||||
value
|
||||
required?
|
||||
single-char
|
||||
predicate
|
||||
value-policy)))
|
||||
|
||||
(define option-spec (make-record-type 'option-spec option-spec-fields))
|
||||
(define make-option-spec (record-constructor option-spec option-spec-fields))
|
||||
|
||||
(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
|
||||
(eval-when (eval load compile)
|
||||
;; The following procedures are used only at compile-time when expanding
|
||||
;; `define-all-option-spec-accessors/modifiers' (see below).
|
||||
|
||||
(define (define-one-option-spec-field-accessor field)
|
||||
`(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
|
||||
`(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
|
||||
(record-accessor option-spec ',field)))
|
||||
|
||||
(define (define-one-option-spec-field-modifier field)
|
||||
`(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
|
||||
(record-modifier option-spec ',field)))))
|
||||
`(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
|
||||
(record-modifier option-spec ',field))))
|
||||
|
||||
(defmacro define-all-option-spec-accessors/modifiers ()
|
||||
`(begin
|
||||
|
|
|
|||
|
|
@ -83,9 +83,8 @@
|
|||
locale-yes-regexp locale-no-regexp))
|
||||
|
||||
|
||||
(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(load-extension "libguile-i18n-v-0" "scm_init_i18n")))
|
||||
(eval-when (eval load compile)
|
||||
(load-extension "libguile-i18n-v-0" "scm_init_i18n"))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -351,36 +351,13 @@
|
|||
(-> (ref (ghil-var-at-module! e modname sym #f)))))
|
||||
|
||||
(define *the-compile-toplevel-symbol* 'compile-toplevel)
|
||||
(define-scheme-translator eval-case
|
||||
(,clauses
|
||||
(retrans
|
||||
`(begin
|
||||
;; Compilation of toplevel units is always wrapped in a lambda
|
||||
,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e))))
|
||||
(let loop ((seen '()) (in clauses) (runtime '()))
|
||||
(cond
|
||||
((null? in) runtime)
|
||||
(else
|
||||
(pmatch (car in)
|
||||
((else . ,body)
|
||||
(if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
|
||||
(primitive-eval `(begin ,@body)))
|
||||
(if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
|
||||
runtime
|
||||
body))
|
||||
((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
|
||||
(for-each (lambda (k)
|
||||
(if (memq k seen)
|
||||
(syntax-error l "eval-case condition seen twice" k)))
|
||||
keys)
|
||||
(if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
|
||||
(primitive-eval `(begin ,@body)))
|
||||
(loop (append keys seen)
|
||||
(cdr in)
|
||||
(if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
|
||||
(append runtime body)
|
||||
runtime)))
|
||||
(else (syntax-error l "bad eval-case clause" (car in))))))))))))
|
||||
(define-scheme-translator eval-when
|
||||
((,when . ,body) (guard (list? when) (and-map symbol? when))
|
||||
(if (memq 'compile when)
|
||||
(primitive-eval `(begin . ,body)))
|
||||
(if (memq 'load when)
|
||||
(retrans `(begin . ,body))
|
||||
(retrans `(begin)))))
|
||||
|
||||
(define-scheme-translator apply
|
||||
;; FIXME: not hygienic, relies on @apply not being shadowed
|
||||
|
|
|
|||
|
|
@ -118,7 +118,8 @@
|
|||
(-> `(,'quasiquote
|
||||
,(let lp ((x obj) (level 0))
|
||||
(cond ((not (apair? x)) x)
|
||||
((memq (acar x) '(,'unquote ,'unquote-splicing))
|
||||
;; FIXME: hygiene regarding imported , / ,@ rebinding
|
||||
((memq (acar x) '(unquote unquote-splicing))
|
||||
(amatch (acdr x)
|
||||
((,obj)
|
||||
(cond
|
||||
|
|
@ -264,6 +265,9 @@
|
|||
|
||||
(define-scheme-expander lambda
|
||||
;; (lambda FORMALS BODY...)
|
||||
((,formals ,docstring ,body1 . ,body) (guard (string? docstring))
|
||||
(-> `(lambda ,formals ,docstring ,(expand-internal-defines
|
||||
(map re-expand (cons body1 body))))))
|
||||
((,formals . ,body)
|
||||
(-> `(lambda ,formals ,(expand-internal-defines (map re-expand body))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -78,9 +78,8 @@
|
|||
(define *goops-module* (current-module))
|
||||
|
||||
;; First initialize the builtin part of GOOPS
|
||||
(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(%init-goops-builtins)))
|
||||
(eval-when (eval load compile)
|
||||
(%init-goops-builtins))
|
||||
|
||||
;; Then load the rest of GOOPS
|
||||
(use-modules (oop goops util)
|
||||
|
|
@ -88,10 +87,9 @@
|
|||
(oop goops compile))
|
||||
|
||||
|
||||
(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(eval-when (eval load compile)
|
||||
(define min-fixnum (- (expt 2 29)))
|
||||
(define max-fixnum (- (expt 2 29) 1))))
|
||||
(define max-fixnum (- (expt 2 29) 1)))
|
||||
|
||||
;;
|
||||
;; goops-error
|
||||
|
|
@ -1039,8 +1037,7 @@
|
|||
;; the idea is to compile the index into the procedure, for fastest
|
||||
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
|
||||
|
||||
(eval-case
|
||||
((compile-toplevel)
|
||||
(eval-when (compile)
|
||||
(use-modules ((language scheme compile-ghil) :select (define-scheme-translator))
|
||||
((language ghil) :select (make-ghil-inline make-ghil-call))
|
||||
(system base pmatch))
|
||||
|
|
@ -1061,11 +1058,10 @@
|
|||
(make-ghil-inline #f #f 'slot-set
|
||||
(list (retrans obj) (retrans index) (retrans val))))
|
||||
(else
|
||||
(make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))))
|
||||
(make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))
|
||||
|
||||
(eval-case
|
||||
((load-toplevel compile-toplevel)
|
||||
(define num-standard-pre-cache 20)))
|
||||
(eval-when (eval load compile)
|
||||
(define num-standard-pre-cache 20))
|
||||
|
||||
(define-macro (define-standard-accessor-method form . body)
|
||||
(let ((name (caar form))
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
;; There are circularities here; you can't import (oop goops compile)
|
||||
;; before (oop goops). So when compiling, make sure that things are
|
||||
;; kosher.
|
||||
(eval-case ((compile-toplevel) (resolve-module '(oop goops))))
|
||||
(eval-when (compile) (resolve-module '(oop goops)))
|
||||
|
||||
(define-module (oop goops compile)
|
||||
:use-module (oop goops)
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
;; There are circularities here; you can't import (oop goops compile)
|
||||
;; before (oop goops). So when compiling, make sure that things are
|
||||
;; kosher.
|
||||
(eval-case ((compile-toplevel) (resolve-module '(oop goops))))
|
||||
(eval-when (compile) (resolve-module '(oop goops)))
|
||||
|
||||
(define-module (oop goops dispatch)
|
||||
:use-module (oop goops)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue