summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am22
-rw-r--r--module/ice-9/boot-9.scm592
-rw-r--r--module/ice-9/deprecated.scm891
-rw-r--r--module/ice-9/eval.scm15
-rw-r--r--module/ice-9/local-eval.scm6
-rw-r--r--module/ice-9/peg.scm42
-rw-r--r--module/ice-9/peg/cache.scm45
-rw-r--r--module/ice-9/peg/codegen.scm359
-rw-r--r--module/ice-9/peg/simplify-tree.scm97
-rw-r--r--module/ice-9/peg/string-peg.scm273
-rw-r--r--module/ice-9/peg/using-parsers.scm116
-rw-r--r--module/ice-9/poll.scm10
-rw-r--r--module/ice-9/psyntax-pp.scm697
-rw-r--r--module/ice-9/psyntax.scm1153
-rw-r--r--module/ice-9/r4rs.scm243
-rw-r--r--module/ice-9/weak-vector.scm15
-rw-r--r--module/language/assembly/compile-bytecode.scm2
-rw-r--r--module/language/assembly/disassemble.scm4
-rw-r--r--module/language/brainfuck/compile-tree-il.scm54
-rw-r--r--module/language/bytecode/spec.scm7
-rw-r--r--module/language/ecmascript/compile-tree-il.scm170
-rw-r--r--module/language/elisp/bindings.scm80
-rw-r--r--module/language/elisp/boot.el617
-rw-r--r--module/language/elisp/compile-tree-il.scm1046
-rw-r--r--module/language/elisp/falias.scm27
-rw-r--r--module/language/elisp/lexer.scm33
-rw-r--r--module/language/elisp/parser.scm2
-rw-r--r--module/language/elisp/runtime.scm143
-rw-r--r--module/language/elisp/runtime/function-slot.scm119
-rw-r--r--module/language/elisp/runtime/macros.scm208
-rw-r--r--module/language/elisp/runtime/subrs.scm383
-rw-r--r--module/language/elisp/runtime/value-slot.scm3
-rw-r--r--module/language/elisp/spec.scm4
-rw-r--r--module/language/objcode/elf.scm94
-rw-r--r--module/language/objcode/spec.scm1
-rw-r--r--module/language/scheme/decompile-tree-il.scm18
-rw-r--r--module/language/tree-il.scm143
-rw-r--r--module/language/tree-il/analyze.scm74
-rw-r--r--module/language/tree-il/canonicalize.scm18
-rw-r--r--module/language/tree-il/compile-glil.scm469
-rw-r--r--module/language/tree-il/cse.scm77
-rw-r--r--module/language/tree-il/debug.scm23
-rw-r--r--module/language/tree-il/effects.scm61
-rw-r--r--module/language/tree-il/fix-letrec.scm51
-rw-r--r--module/language/tree-il/peval.scm492
-rw-r--r--module/language/tree-il/primitives.scm97
-rw-r--r--module/language/tree-il/spec.scm6
-rw-r--r--module/oop/goops.scm200
-rw-r--r--module/oop/goops/util.scm15
-rw-r--r--module/rnrs/io/ports.scm30
-rw-r--r--module/scripts/disassemble.scm4
-rw-r--r--module/srfi/srfi-18.scm26
-rw-r--r--module/system/foreign.scm4
-rw-r--r--module/system/repl/command.scm4
-rw-r--r--module/system/vm/elf.scm1255
-rw-r--r--module/system/vm/objcode.scm4
-rw-r--r--module/web/server.scm6
57 files changed, 6043 insertions, 4607 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index d43be04d6..4daf7cf51 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -80,15 +80,14 @@ ETAGS_ARGS += \
ice-9/ChangeLog-2008
ice-9/psyntax-pp.scm.gen:
- GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \
- $(top_builddir_absolute)/meta/guile -s $(srcdir)/ice-9/compile-psyntax.scm \
+ $(top_builddir_absolute)/meta/guile --no-auto-compile -s $(srcdir)/ice-9/compile-psyntax.scm \
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
.PHONY: ice-9/psyntax-pp.scm.gen
# Keep this rule in sync with that in `am/guilec'.
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
- $(AM_V_GUILEC)GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \
+ $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
guild compile --target="$(host)" $(GUILE_WARNINGS) \
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
@@ -125,7 +124,8 @@ BYTECODE_LANG_SOURCES = \
language/bytecode/spec.scm
OBJCODE_LANG_SOURCES = \
- language/objcode/spec.scm
+ language/objcode/spec.scm \
+ language/objcode/elf.scm
VALUE_LANG_SOURCES = \
language/value/spec.scm
@@ -141,6 +141,7 @@ ECMASCRIPT_LANG_SOURCES = \
language/ecmascript/spec.scm
ELISP_LANG_SOURCES = \
+ language/elisp/falias.scm \
language/elisp/lexer.scm \
language/elisp/parser.scm \
language/elisp/bindings.scm \
@@ -148,8 +149,6 @@ ELISP_LANG_SOURCES = \
language/elisp/runtime.scm \
language/elisp/runtime/function-slot.scm \
language/elisp/runtime/value-slot.scm \
- language/elisp/runtime/macros.scm \
- language/elisp/runtime/subrs.scm \
language/elisp/spec.scm
BRAINFUCK_LANG_SOURCES = \
@@ -189,7 +188,6 @@ SYSTEM_BASE_SOURCES = \
system/base/ck.scm
ICE_9_SOURCES = \
- ice-9/r4rs.scm \
ice-9/r5rs.scm \
ice-9/deprecated.scm \
ice-9/and-let-star.scm \
@@ -217,6 +215,12 @@ ICE_9_SOURCES = \
ice-9/null.scm \
ice-9/occam-channel.scm \
ice-9/optargs.scm \
+ ice-9/peg/simplify-tree.scm \
+ ice-9/peg/codegen.scm \
+ ice-9/peg/cache.scm \
+ ice-9/peg/using-parsers.scm \
+ ice-9/peg/string-peg.scm \
+ ice-9/peg.scm \
ice-9/poe.scm \
ice-9/poll.scm \
ice-9/posix.scm \
@@ -343,6 +347,7 @@ OOP_SOURCES = \
SYSTEM_SOURCES = \
system/vm/inspect.scm \
system/vm/coverage.scm \
+ system/vm/elf.scm \
system/vm/frame.scm \
system/vm/instruction.scm \
system/vm/objcode.scm \
@@ -390,6 +395,9 @@ WEB_SOURCES = \
EXTRA_DIST += oop/ChangeLog-2008
+ELISP_SOURCES = \
+ language/elisp/boot.el
+
NOCOMP_SOURCES = \
ice-9/match.upstream.scm \
ice-9/psyntax.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 8461ee80d..69a7fbc27 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -51,10 +51,12 @@
(define make-prompt-tag
(lambda* (#:optional (stem "prompt"))
- (gensym stem)))
+ ;; The only property that prompt tags need have is uniqueness in the
+ ;; sense of eq?. A one-element list will serve nicely.
+ (list stem)))
(define default-prompt-tag
- ;; not sure if we should expose this to the user as a fluid
+ ;; Redefined later to be a parameter.
(let ((%default-prompt-tag (make-prompt-tag)))
(lambda ()
%default-prompt-tag)))
@@ -186,10 +188,105 @@ If there is no handler at all, Guile prints an error and then exits."
-;;; {R4RS compliance}
+;;; {Language primitives}
;;;
-(primitive-load-path "ice-9/r4rs")
+;; These are are the procedural wrappers around the primitives of
+;; Guile's language: @apply, @call-with-current-continuation, etc.
+;;
+;; Usually, a call to a primitive is compiled specially. The compiler
+;; knows about all these kinds of expressions. But the primitives may
+;; be referenced not only as operators, but as values as well. These
+;; stub procedures are the "values" of apply, dynamic-wind, and other
+;; such primitives.
+;;
+(define (apply fun . args)
+ (@apply fun (apply:nconc2last args)))
+(define (call-with-current-continuation proc)
+ (@call-with-current-continuation proc))
+(define (call-with-values producer consumer)
+ (@call-with-values producer consumer))
+(define (dynamic-wind in thunk out)
+ "All three arguments must be 0-argument procedures.
+Guard @var{in} is called, then @var{thunk}, then
+guard @var{out}.
+
+If, any time during the execution of @var{thunk}, the
+continuation of the @code{dynamic_wind} expression is escaped
+non-locally, @var{out} is called. If the continuation of
+the dynamic-wind is re-entered, @var{in} is called. Thus
+@var{in} and @var{out} may be called any number of
+times.
+@lisp
+ (define x 'normal-binding)
+@result{} x
+ (define a-cont
+ (call-with-current-continuation
+ (lambda (escape)
+ (let ((old-x x))
+ (dynamic-wind
+ ;; in-guard:
+ ;;
+ (lambda () (set! x 'special-binding))
+
+ ;; thunk
+ ;;
+ (lambda () (display x) (newline)
+ (call-with-current-continuation escape)
+ (display x) (newline)
+ x)
+
+ ;; out-guard:
+ ;;
+ (lambda () (set! x old-x)))))))
+
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont
+x
+@result{} normal-binding
+ (a-cont #f)
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont ;; the value of the (define a-cont...)
+x
+@result{} normal-binding
+a-cont
+@result{} special-binding
+@end lisp"
+ (@dynamic-wind in (thunk) out))
+
+
+
+;;; {Low-Level Port Code}
+;;;
+
+;; These are used to request the proper mode to open files in.
+;;
+(define OPEN_READ "r")
+(define OPEN_WRITE "w")
+(define OPEN_BOTH "r+")
+
+(define *null-device* "/dev/null")
+
+(define (open-input-file str)
+ "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file. If the file
+cannot be opened, an error is signalled."
+ (open-file str OPEN_READ))
+
+(define (open-output-file str)
+ "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name. If the file cannot be opened, an error is signalled. If a
+file with the given name already exists, the effect is unspecified."
+ (open-file str OPEN_WRITE))
+
+(define (open-io-file str)
+ "Open file with name STR for both input and output."
+ (open-file str OPEN_BOTH))
@@ -218,13 +315,11 @@ If there is no handler at all, Guile prints an error and then exits."
(define current-warning-port current-error-port)
(define (warn . stuff)
- (with-output-to-port (current-warning-port)
- (lambda ()
- (newline)
- (display ";;; WARNING ")
- (display stuff)
- (newline)
- (car (last-pair stuff)))))
+ (newline (current-warning-port))
+ (display ";;; WARNING " (current-warning-port))
+ (display stuff (current-warning-port))
+ (newline (current-warning-port))
+ (car (last-pair stuff)))
@@ -988,15 +1083,11 @@ VALUE."
;; properties within the object itself.
(define (make-object-property)
- (define-syntax-rule (with-mutex lock exp)
- (dynamic-wind (lambda () (lock-mutex lock))
- (lambda () exp)
- (lambda () (unlock-mutex lock))))
- (let ((prop (make-weak-key-hash-table))
- (lock (make-mutex)))
+ ;; Weak tables are thread-safe.
+ (let ((prop (make-weak-key-hash-table)))
(make-procedure-with-setter
- (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
- (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
+ (lambda (obj) (hashq-ref prop obj))
+ (lambda (obj val) (hashq-set! prop obj val)))))
@@ -1212,6 +1303,281 @@ VALUE."
(provide 'record)
+
+
+;;; {Parameters}
+;;;
+
+(define <parameter>
+ ;; Three fields: the procedure itself, the fluid, and the converter.
+ (make-struct <applicable-struct-vtable> 0 'pwprpr))
+(set-struct-vtable-name! <parameter> '<parameter>)
+
+(define* (make-parameter init #:optional (conv (lambda (x) x)))
+ "Make a new parameter.
+
+A parameter is a dynamically bound value, accessed through a procedure.
+To access the current value, apply the procedure with no arguments:
+
+ (define p (make-parameter 10))
+ (p) => 10
+
+To provide a new value for the parameter in a dynamic extent, use
+`parameterize':
+
+ (parameterize ((p 20))
+ (p)) => 20
+ (p) => 10
+
+The value outside of the dynamic extent of the body is unaffected. To
+update the current value, apply it to one argument:
+
+ (p 20) => 10
+ (p) => 20
+
+As you can see, the call that updates a parameter returns its previous
+value.
+
+All values for the parameter are first run through the CONV procedure,
+including INIT, the initial value. The default CONV procedure is the
+identity procedure. CONV is commonly used to ensure some set of
+invariants on the values that a parameter may have."
+ (let ((fluid (make-fluid (conv init))))
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv)))
+
+(define (parameter? x)
+ (and (struct? x) (eq? (struct-vtable x) <parameter>)))
+
+(define (parameter-fluid p)
+ (if (parameter? p)
+ (struct-ref p 1)
+ (scm-error 'wrong-type-arg "parameter-fluid"
+ "Not a parameter: ~S" (list p) #f)))
+
+(define (parameter-converter p)
+ (if (parameter? p)
+ (struct-ref p 2)
+ (scm-error 'wrong-type-arg "parameter-fluid"
+ "Not a parameter: ~S" (list p) #f)))
+
+(define-syntax parameterize
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((param value) ...) body body* ...)
+ (with-syntax (((p ...) (generate-temporaries #'(param ...))))
+ #'(let ((p param) ...)
+ (if (not (parameter? p))
+ (scm-error 'wrong-type-arg "parameterize"
+ "Not a parameter: ~S" (list p) #f))
+ ...
+ (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
+ ...)
+ body body* ...)))))))
+
+(define* (fluid->parameter fluid #:optional (conv (lambda (x) x)))
+ "Make a parameter that wraps a fluid.
+
+The value of the parameter will be the same as the value of the fluid.
+If the parameter is rebound in some dynamic extent, perhaps via
+`parameterize', the new value will be run through the optional CONV
+procedure, as with any parameter. Note that unlike `make-parameter',
+CONV is not applied to the initial value."
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv))
+
+
+
+;;; Once parameters have booted, define the default prompt tag as being
+;;; a parameter.
+;;;
+
+(set! default-prompt-tag (make-parameter (default-prompt-tag)))
+
+
+
+;;; Current ports as parameters.
+;;;
+
+(let ()
+ (define-syntax-rule (port-parameterize! binding fluid predicate msg)
+ (begin
+ (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
+ (lambda (x)
+ (if (predicate x) x
+ (error msg x)))))
+ (hashq-remove! (%get-pre-modules-obarray) 'fluid)))
+
+ (port-parameterize! current-input-port %current-input-port-fluid
+ input-port? "expected an input port")
+ (port-parameterize! current-output-port %current-output-port-fluid
+ output-port? "expected an output port")
+ (port-parameterize! current-error-port %current-error-port-fluid
+ output-port? "expected an output port"))
+
+
+
+;;; {Warnings}
+;;;
+
+(define current-warning-port
+ (make-parameter (current-error-port)
+ (lambda (x)
+ (if (output-port? x)
+ x
+ (error "expected an output port" x)))))
+
+
+
+
+;;; {Languages}
+;;;
+
+;; The language can be a symbolic name or a <language> object from
+;; (system base language).
+;;
+(define current-language (make-parameter 'scheme))
+
+
+
+
+;;; {High-Level Port Routines}
+;;;
+
+(define (call-with-input-file str proc)
+ "PROC should be a procedure of one argument, and STR should be a
+string naming a file. The file must already exist. These procedures
+call PROC with one argument: the port obtained by opening the named file
+for input or output. If the file cannot be opened, an error is
+signalled. If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned. If
+the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will never
+again be used for a read or write operation."
+ (let ((p (open-input-file str)))
+ (call-with-values
+ (lambda () (proc p))
+ (lambda vals
+ (close-input-port p)
+ (apply values vals)))))
+
+(define (call-with-output-file str proc)
+ "PROC should be a procedure of one argument, and STR should be a
+string naming a file. The behaviour is unspecified if the file
+already exists. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output. If the file cannot be opened, an error is
+signalled. If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+ (let ((p (open-output-file str)))
+ (call-with-values
+ (lambda () (proc p))
+ (lambda vals
+ (close-output-port p)
+ (apply values vals)))))
+
+(define (with-input-from-port port thunk)
+ (parameterize ((current-input-port port))
+ (thunk)))
+
+(define (with-output-to-port port thunk)
+ (parameterize ((current-output-port port))
+ (thunk)))
+
+(define (with-error-to-port port thunk)
+ (parameterize ((current-error-port port))
+ (thunk)))
+
+(define (with-input-from-file file thunk)
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The file must already exist. The file is opened for
+input, an input port connected to it is made
+the default value returned by `current-input-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-input-file file
+ (lambda (p) (with-input-from-port p thunk))))
+
+(define (with-output-to-file file thunk)
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-output-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-output-file file
+ (lambda (p) (with-output-to-port p thunk))))
+
+(define (with-error-to-file file thunk)
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-error-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-output-file file
+ (lambda (p) (with-error-to-port p thunk))))
+
+(define (call-with-input-string string proc)
+ "Calls the one-argument procedure @var{proc} with a newly created
+input port from which @var{string}'s contents may be read. The value
+yielded by the @var{proc} is returned."
+ (proc (open-input-string string)))
+
+(define (with-input-from-string string thunk)
+ "THUNK must be a procedure of no arguments.
+The test of STRING is opened for
+input, an input port connected to it is made,
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed.
+Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-input-string string
+ (lambda (p) (with-input-from-port p thunk))))
+
+(define (call-with-output-string proc)
+ "Calls the one-argument procedure @var{proc} with a newly created output
+port. When the function returns, the string composed of the characters
+written into the port is returned."
+ (let ((port (open-output-string)))
+ (proc port)
+ (get-output-string port)))
+
+(define (with-output-to-string thunk)
+ "Calls THUNK and returns its output as a string."
+ (call-with-output-string
+ (lambda (p) (with-output-to-port p thunk))))
+
+(define (with-error-to-string thunk)
+ "Calls THUNK and returns its error output as a string."
+ (call-with-output-string
+ (lambda (p) (with-error-to-port p thunk))))
+
+(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
+
;;; {Booleans}
@@ -1261,7 +1627,7 @@ VALUE."
(lambda (str)
(->bool (stat str #f)))
(lambda (str)
- (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+ (let ((port (catch 'system-error (lambda () (open-input-file str))
(lambda args #f))))
(if port (begin (close-port port) #t)
#f)))))
@@ -1272,8 +1638,8 @@ VALUE."
(eq? (stat:type (stat str)) 'directory))
(lambda (str)
(let ((port (catch 'system-error
- (lambda () (open-file (string-append str "/.")
- OPEN_READ))
+ (lambda ()
+ (open-input-file (string-append str "/.")))
(lambda args #f))))
(if port (begin (close-port port) #t)
#f)))))
@@ -1703,7 +2069,7 @@ VALUE."
((define-record-type
(lambda (x)
(define (make-id scope . fragments)
- (datum->syntax #'scope
+ (datum->syntax scope
(apply symbol-append
(map (lambda (x)
(if (symbol? x) x (syntax->datum x)))
@@ -1838,10 +2204,6 @@ VALUE."
;; initial uses list, or binding procedure.
;;
(define* (make-module #:optional (size 31) (uses '()) (binder #f))
- (define %default-import-size
- ;; Typical number of imported bindings actually used by a module.
- 600)
-
(if (not (integer? size))
(error "Illegal size to make-module." size))
(if (not (and (list? uses)
@@ -1854,7 +2216,7 @@ VALUE."
(module-constructor (make-hash-table size)
uses binder #f macroexpand
#f #f #f
- (make-hash-table %default-import-size)
+ (make-hash-table)
'()
(make-weak-key-hash-table 31) #f
(make-hash-table 7) #f #f #f))
@@ -2172,33 +2534,6 @@ VALUE."
(define (module-define-submodule! module name submodule)
(hashq-set! (module-submodules module) name submodule))
-;; It used to be, however, that module names were also present in the
-;; value namespace. When we enable deprecated code, we preserve this
-;; legacy behavior.
-;;
-;; These shims are defined here instead of in deprecated.scm because we
-;; need their definitions before loading other modules.
-;;
-(begin-deprecated
- (define (module-ref-submodule module name)
- (or (hashq-ref (module-submodules module) name)
- (and (module-submodule-binder module)
- ((module-submodule-binder module) module name))
- (let ((var (module-local-variable module name)))
- (and var (variable-bound? var) (module? (variable-ref var))
- (begin
- (warn "module" module "not in submodules table")
- (variable-ref var))))))
-
- (define (module-define-submodule! module name submodule)
- (let ((var (module-local-variable module name)))
- (if (and var
- (or (not (variable-bound? var))
- (not (module? (variable-ref var)))))
- (warn "defining module" module ": not overriding local definition" var)
- (module-define! module name submodule)))
- (hashq-set! (module-submodules module) name submodule)))
-
;;; {Module-based Loading}
@@ -3002,145 +3337,6 @@ but it fails to load."
-;;; {Parameters}
-;;;
-
-(define <parameter>
- ;; Three fields: the procedure itself, the fluid, and the converter.
- (make-struct <applicable-struct-vtable> 0 'pwprpr))
-(set-struct-vtable-name! <parameter> '<parameter>)
-
-(define* (make-parameter init #:optional (conv (lambda (x) x)))
- "Make a new parameter.
-
-A parameter is a dynamically bound value, accessed through a procedure.
-To access the current value, apply the procedure with no arguments:
-
- (define p (make-parameter 10))
- (p) => 10
-
-To provide a new value for the parameter in a dynamic extent, use
-`parameterize':
-
- (parameterize ((p 20))
- (p)) => 20
- (p) => 10
-
-The value outside of the dynamic extent of the body is unaffected. To
-update the current value, apply it to one argument:
-
- (p 20) => 10
- (p) => 20
-
-As you can see, the call that updates a parameter returns its previous
-value.
-
-All values for the parameter are first run through the CONV procedure,
-including INIT, the initial value. The default CONV procedure is the
-identity procedure. CONV is commonly used to ensure some set of
-invariants on the values that a parameter may have."
- (let ((fluid (make-fluid (conv init))))
- (make-struct <parameter> 0
- (case-lambda
- (() (fluid-ref fluid))
- ((x) (let ((prev (fluid-ref fluid)))
- (fluid-set! fluid (conv x))
- prev)))
- fluid conv)))
-
-(define* (fluid->parameter fluid #:optional (conv (lambda (x) x)))
- "Make a parameter that wraps a fluid.
-
-The value of the parameter will be the same as the value of the fluid.
-If the parameter is rebound in some dynamic extent, perhaps via
-`parameterize', the new value will be run through the optional CONV
-procedure, as with any parameter. Note that unlike `make-parameter',
-CONV is not applied to the initial value."
- (make-struct <parameter> 0
- (case-lambda
- (() (fluid-ref fluid))
- ((x) (let ((prev (fluid-ref fluid)))
- (fluid-set! fluid (conv x))
- prev)))
- fluid conv))
-
-(define (parameter? x)
- (and (struct? x) (eq? (struct-vtable x) <parameter>)))
-
-(define (parameter-fluid p)
- (if (parameter? p)
- (struct-ref p 1)
- (scm-error 'wrong-type-arg "parameter-fluid"
- "Not a parameter: ~S" (list p) #f)))
-
-(define (parameter-converter p)
- (if (parameter? p)
- (struct-ref p 2)
- (scm-error 'wrong-type-arg "parameter-fluid"
- "Not a parameter: ~S" (list p) #f)))
-
-(define-syntax parameterize
- (lambda (x)
- (syntax-case x ()
- ((_ ((param value) ...) body body* ...)
- (with-syntax (((p ...) (generate-temporaries #'(param ...))))
- #'(let ((p param) ...)
- (if (not (parameter? p))
- (scm-error 'wrong-type-arg "parameterize"
- "Not a parameter: ~S" (list p) #f))
- ...
- (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
- ...)
- body body* ...)))))))
-
-
-;;;
-;;; Current ports as parameters.
-;;;
-
-(let ()
- (define-syntax-rule (port-parameterize! binding fluid predicate msg)
- (begin
- (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
- (lambda (x)
- (if (predicate x) x
- (error msg x)))))
- (module-remove! (current-module) 'fluid)))
-
- (port-parameterize! current-input-port %current-input-port-fluid
- input-port? "expected an input port")
- (port-parameterize! current-output-port %current-output-port-fluid
- output-port? "expected an output port")
- (port-parameterize! current-error-port %current-error-port-fluid
- output-port? "expected an output port"))
-
-
-
-;;;
-;;; Warnings.
-;;;
-
-(define current-warning-port
- (make-parameter (current-error-port)
- (lambda (x)
- (if (output-port? x)
- x
- (error "expected an output port" x)))))
-
-
-
-;;;
-;;; Languages.
-;;;
-
-;; The language can be a symbolic name or a <language> object from
-;; (system base language).
-;;
-(define current-language (make-parameter 'scheme))
-
-
-
-
;;; {Running Repls}
;;;
@@ -3451,13 +3647,6 @@ CONV is not applied to the initial value."
(process-use-modules (list quoted-args ...))
*unspecified*))))))
-(define-syntax-rule (use-syntax spec ...)
- (begin
- (eval-when (eval load compile expand)
- (issue-deprecation-warning
- "`use-syntax' is deprecated. Please contact guile-devel for more info."))
- (use-modules spec ...)))
-
(include-from-path "ice-9/r6rs-libraries")
(define-syntax-rule (define-private foo bar)
@@ -3909,6 +4098,7 @@ when none is available, reading FILE-NAME with READER."
;; placing 'cond-expand-provide' in the relevant module.
'(guile
guile-2
+ guile-2.2
r5rs
srfi-0 ;; cond-expand itself
srfi-4 ;; homogeneous numeric vectors
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 56b9c0495..9835c1230 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -16,893 +16,4 @@
;;;;
(define-module (ice-9 deprecated)
- #:export (substring-move-left! substring-move-right!
- dynamic-maybe-call dynamic-maybe-link
- try-module-linked try-module-dynamic-link
- list* feature? eval-case unmemoize-expr
- $asinh
- $acosh
- $atanh
- $sqrt
- $abs
- $exp
- $expt
- $log
- $sin
- $cos
- $tan
- $asin
- $acos
- $atan
- $sinh
- $cosh
- $tanh
- closure?
- %nil
- @bind
- bad-throw
- error-catching-loop
- error-catching-repl
- scm-style-repl
- apply-to-args
- has-suffix?
- scheme-file-suffix
- get-option
- for-next-option
- display-usage-report
- transform-usage-lambda
- collect
- assert-repl-silence
- assert-repl-print-unspecified
- assert-repl-verbosity
- set-repl-prompt!
- set-batch-mode?!
- repl
- pre-unwind-handler-dispatch
- default-pre-unwind-handler
- handle-system-error
- stack-saved?
- the-last-stack
- save-stack
- named-module-use!
- top-repl
- turn-on-debugging
- read-hash-procedures
- process-define-module
- fluid-let-syntax
- set-system-module!
- char-code-limit
- generalized-vector?
- generalized-vector-length
- generalized-vector-ref
- generalized-vector-set!
- generalized-vector->list))
-
-
-;;;; Deprecated definitions.
-
-(define substring-move-left!
- (lambda args
- (issue-deprecation-warning
- "`substring-move-left!' is deprecated. Use `substring-move!' instead.")
- (apply substring-move! args)))
-(define substring-move-right!
- (lambda args
- (issue-deprecation-warning
- "`substring-move-right!' is deprecated. Use `substring-move!' instead.")
- (apply substring-move! args)))
-
-
-
-;; This method of dynamically linking Guile Extensions is deprecated.
-;; Use `load-extension' explicitly from Scheme code instead.
-
-(define (split-c-module-name str)
- (let loop ((rev '())
- (start 0)
- (pos 0)
- (end (string-length str)))
- (cond
- ((= pos end)
- (reverse (cons (string->symbol (substring str start pos)) rev)))
- ((eq? (string-ref str pos) #\space)
- (loop (cons (string->symbol (substring str start pos)) rev)
- (+ pos 1)
- (+ pos 1)
- end))
- (else
- (loop rev start (+ pos 1) end)))))
-
-(define (convert-c-registered-modules dynobj)
- (let ((res (map (lambda (c)
- (list (split-c-module-name (car c)) (cdr c) dynobj))
- (c-registered-modules))))
- (c-clear-registered-modules)
- res))
-
-(define registered-modules '())
-
-(define (register-modules dynobj)
- (set! registered-modules
- (append! (convert-c-registered-modules dynobj)
- registered-modules)))
-
-(define (warn-autoload-deprecation modname)
- (issue-deprecation-warning
- "Autoloading of compiled code modules is deprecated."
- "Write a Scheme file instead that uses `load-extension'.")
- (issue-deprecation-warning
- (simple-format #f "(You just autoloaded module ~S.)" modname)))
-
-(define (init-dynamic-module modname)
- ;; Register any linked modules which have been registered on the C level
- (register-modules #f)
- (or-map (lambda (modinfo)
- (if (equal? (car modinfo) modname)
- (begin
- (warn-autoload-deprecation modname)
- (set! registered-modules (delq! modinfo registered-modules))
- (let ((mod (resolve-module modname #f)))
- (save-module-excursion
- (lambda ()
- (set-current-module mod)
- (set-module-public-interface! mod mod)
- (dynamic-call (cadr modinfo) (caddr modinfo))
- ))
- #t))
- #f))
- registered-modules))
-
-(define (dynamic-maybe-call name dynobj)
- (issue-deprecation-warning
- "`dynamic-maybe-call' is deprecated. "
- "Wrap `dynamic-call' in a `false-if-exception' yourself.")
- (false-if-exception (dynamic-call name dynobj)))
-
-
-(define (dynamic-maybe-link filename)
- (issue-deprecation-warning
- "`dynamic-maybe-link' is deprecated. "
- "Wrap `dynamic-link' in a `false-if-exception' yourself.")
- (false-if-exception (dynamic-link filename)))
-
-(define (find-and-link-dynamic-module module-name)
- (define (make-init-name mod-name)
- (string-append "scm_init"
- (list->string (map (lambda (c)
- (if (or (char-alphabetic? c)
- (char-numeric? c))
- c
- #\_))
- (string->list mod-name)))
- "_module"))
-
- ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
- ;; and the `libname' (the name of the module prepended by `lib') in the cdr
- ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then
- ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
- (let ((subdir-and-libname
- (let loop ((dirs "")
- (syms module-name))
- (if (null? (cdr syms))
- (cons dirs (string-append "lib" (symbol->string (car syms))))
- (loop (string-append dirs (symbol->string (car syms)) "/")
- (cdr syms)))))
- (init (make-init-name (apply string-append
- (map (lambda (s)
- (string-append "_"
- (symbol->string s)))
- module-name)))))
- (let ((subdir (car subdir-and-libname))
- (libname (cdr subdir-and-libname)))
-
- ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that
- ;; file exists, fetch the dlname from that file and attempt to link
- ;; against it. If `subdir/libfoo.la' does not exist, or does not seem
- ;; to name any shared library, look for `subdir/libfoo.so' instead and
- ;; link against that.
- (let check-dirs ((dir-list %load-path))
- (if (null? dir-list)
- #f
- (let* ((dir (in-vicinity (car dir-list) subdir))
- (sharlib-full
- (or (try-using-libtool-name dir libname)
- (try-using-sharlib-name dir libname))))
- (if (and sharlib-full (file-exists? sharlib-full))
- (link-dynamic-module sharlib-full init)
- (check-dirs (cdr dir-list)))))))))
-
-(define (try-using-libtool-name libdir libname)
- (let ((libtool-filename (in-vicinity libdir
- (string-append libname ".la"))))
- (and (file-exists? libtool-filename)
- libtool-filename)))
-
-(define (try-using-sharlib-name libdir libname)
- (in-vicinity libdir (string-append libname ".so")))
-
-(define (link-dynamic-module filename initname)
- ;; Register any linked modules which have been registered on the C level
- (register-modules #f)
- (let ((dynobj (dynamic-link filename)))
- (dynamic-call initname dynobj)
- (register-modules dynobj)))
-
-(define (try-module-linked module-name)
- (issue-deprecation-warning
- "`try-module-linked' is deprecated."
- "See the manual for how more on C extensions.")
- (init-dynamic-module module-name))
-
-(define (try-module-dynamic-link module-name)
- (issue-deprecation-warning
- "`try-module-dynamic-link' is deprecated."
- "See the manual for how more on C extensions.")
- (and (find-and-link-dynamic-module module-name)
- (init-dynamic-module module-name)))
-
-
-(define (list* . args)
- (issue-deprecation-warning "'list*' is deprecated. Use 'cons*' instead.")
- (apply cons* args))
-
-(define (feature? sym)
- (issue-deprecation-warning
- "`feature?' is deprecated. Use `provided?' instead.")
- (provided? sym))
-
-(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))))
-
-;; The strange prototype system for uniform arrays has been
-;; deprecated.
-(read-hash-extend
- #\y
- (lambda (c port)
- (issue-deprecation-warning
- "The `#y' bytevector syntax is deprecated. Use `#s8' instead.")
- (let ((x (read port)))
- (cond
- ((list? x) (list->s8vector x))
- (else (error "#y needs to be followed by a list" x))))))
-
-(define (unmemoize-expr . args)
- (issue-deprecation-warning
- "`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
- (apply unmemoize-expression args))
-
-(define ($asinh z)
- (issue-deprecation-warning
- "`$asinh' is deprecated. Use `asinh' instead.")
- (asinh z))
-(define ($acosh z)
- (issue-deprecation-warning
- "`$acosh' is deprecated. Use `acosh' instead.")
- (acosh z))
-(define ($atanh z)
- (issue-deprecation-warning
- "`$atanh' is deprecated. Use `atanh' instead.")
- (atanh z))
-(define ($sqrt z)
- (issue-deprecation-warning
- "`$sqrt' is deprecated. Use `sqrt' instead.")
- (sqrt z))
-(define ($abs z)
- (issue-deprecation-warning
- "`$abs' is deprecated. Use `abs' instead.")
- (abs z))
-(define ($exp z)
- (issue-deprecation-warning
- "`$exp' is deprecated. Use `exp' instead.")
- (exp z))
-(define ($expt z1 z2)
- (issue-deprecation-warning
- "`$expt' is deprecated. Use `expt' instead.")
- (expt z1 z2))
-(define ($log z)
- (issue-deprecation-warning
- "`$log' is deprecated. Use `log' instead.")
- (log z))
-(define ($sin z)
- (issue-deprecation-warning
- "`$sin' is deprecated. Use `sin' instead.")
- (sin z))
-(define ($cos z)
- (issue-deprecation-warning
- "`$cos' is deprecated. Use `cos' instead.")
- (cos z))
-(define ($tan z)
- (issue-deprecation-warning
- "`$tan' is deprecated. Use `tan' instead.")
- (tan z))
-(define ($asin z)
- (issue-deprecation-warning
- "`$asin' is deprecated. Use `asin' instead.")
- (asin z))
-(define ($acos z)
- (issue-deprecation-warning
- "`$acos' is deprecated. Use `acos' instead.")
- (acos z))
-(define ($atan z)
- (issue-deprecation-warning
- "`$atan' is deprecated. Use `atan' instead.")
- (atan z))
-(define ($sinh z)
- (issue-deprecation-warning
- "`$sinh' is deprecated. Use `sinh' instead.")
- (sinh z))
-(define ($cosh z)
- (issue-deprecation-warning
- "`$cosh' is deprecated. Use `cosh' instead.")
- (cosh z))
-(define ($tanh z)
- (issue-deprecation-warning
- "`$tanh' is deprecated. Use `tanh' instead.")
- (tanh z))
-
-(define (closure? x)
- (issue-deprecation-warning
- "`closure?' is deprecated. Use `procedure?' instead.")
- (procedure? x))
-
-(define %nil #nil)
-
-;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
-;;; Please let the Guile developers know if you are using this macro.
-;;;
-(define-syntax @bind
- (lambda (x)
- (define (bound-member id ids)
- (cond ((null? ids) #f)
- ((bound-identifier=? id (car ids)) #t)
- ((bound-member (car ids) (cdr ids)))))
-
- (issue-deprecation-warning
- "`@bind' is deprecated. Use `with-fluids' instead.")
-
- (syntax-case x ()
- ((_ () b0 b1 ...)
- #'(let () b0 b1 ...))
- ((_ ((id val) ...) b0 b1 ...)
- (and-map identifier? #'(id ...))
- (if (let lp ((ids #'(id ...)))
- (cond ((null? ids) #f)
- ((bound-member (car ids) (cdr ids)) #t)
- (else (lp (cdr ids)))))
- (syntax-violation '@bind "duplicate bound identifier" x)
- (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
- ((v ...) (generate-temporaries #'(id ...))))
- #'(let ((old-v id) ...
- (v val) ...)
- (dynamic-wind
- (lambda ()
- (set! id v) ...)
- (lambda () b0 b1 ...)
- (lambda ()
- (set! id old-v) ...)))))))))
-
-;; There are deprecated definitions for module-ref-submodule and
-;; module-define-submodule! in boot-9.scm.
-
-;; Define (%app) and (%app modules), and have (app) alias (%app). This
-;; side-effects the-root-module, both to the submodules table and (through
-;; module-define-submodule! above) the obarray.
-;;
-(let ((%app (make-module 31)))
- (set-module-name! %app '(%app))
- (module-define-submodule! the-root-module '%app %app)
- (module-define-submodule! the-root-module 'app %app)
- (module-define-submodule! %app 'modules (resolve-module '() #f)))
-
-;; Allow code that poked %module-public-interface to keep on working.
-;;
-(set! module-public-interface
- (let ((getter module-public-interface))
- (lambda (mod)
- (or (getter mod)
- (cond
- ((and=> (module-local-variable mod '%module-public-interface)
- variable-ref)
- => (lambda (iface)
- (issue-deprecation-warning
-"Setting a module's public interface via munging %module-public-interface is
-deprecated. Use set-module-public-interface! instead.")
- (set-module-public-interface! mod iface)
- iface))
- (else #f))))))
-
-(set! set-module-public-interface!
- (let ((setter set-module-public-interface!))
- (lambda (mod iface)
- (setter mod iface)
- (module-define! mod '%module-public-interface iface))))
-
-(define (bad-throw key . args)
- (issue-deprecation-warning
- "`bad-throw' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- (apply (@ (ice-9 scm-style-repl) bad-throw) key args))
-
-(define (error-catching-loop thunk)
- (issue-deprecation-warning
- "`error-catching-loop' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- ((@ (ice-9 scm-style-repl) error-catching-loop) thunk))
-
-(define (error-catching-repl r e p)
- (issue-deprecation-warning
- "`error-catching-repl' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- ((@ (ice-9 scm-style-repl) error-catching-repl) r e p))
-
-(define (scm-style-repl)
- (issue-deprecation-warning
- "`scm-style-repl' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead, or
-better yet, use the repl from `(system repl repl)'.")
- ((@ (ice-9 scm-style-repl) scm-style-repl)))
-
-
-;;; Apply-to-args had the following comment attached to it in boot-9, but it's
-;;; wrong-headed: in the mentioned case, a point should either be a record or
-;;; multiple values.
-;;;
-;;; apply-to-args is functionally redundant with apply and, worse,
-;;; is less general than apply since it only takes two arguments.
-;;;
-;;; On the other hand, apply-to-args is a syntacticly convenient way to
-;;; perform binding in many circumstances when the "let" family of
-;;; of forms don't cut it. E.g.:
-;;;
-;;; (apply-to-args (return-3d-mouse-coords)
-;;; (lambda (x y z)
-;;; ...))
-;;;
-
-(define (apply-to-args args fn)
- (issue-deprecation-warning
- "`apply-to-args' is deprecated. Include a local copy in your program.")
- (apply fn args))
-
-(define (has-suffix? str suffix)
- (issue-deprecation-warning
- "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).")
- (string-suffix? suffix str))
-
-(define scheme-file-suffix
- (lambda ()
- (issue-deprecation-warning
- "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.")
- ".scm"))
-
-
-
-;;; {Command Line Options}
-;;;
-
-(define (get-option argv kw-opts kw-args return)
- (issue-deprecation-warning
- "`get-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (cond
- ((null? argv)
- (return #f #f argv))
-
- ((or (not (eq? #\- (string-ref (car argv) 0)))
- (eq? (string-length (car argv)) 1))
- (return 'normal-arg (car argv) (cdr argv)))
-
- ((eq? #\- (string-ref (car argv) 1))
- (let* ((kw-arg-pos (or (string-index (car argv) #\=)
- (string-length (car argv))))
- (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
- (kw-opt? (member kw kw-opts))
- (kw-arg? (member kw kw-args))
- (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
- (substring (car argv)
- (+ kw-arg-pos 1)
- (string-length (car argv))))
- (and kw-arg?
- (begin (set! argv (cdr argv)) (car argv))))))
- (if (or kw-opt? kw-arg?)
- (return kw arg (cdr argv))
- (return 'usage-error kw (cdr argv)))))
-
- (else
- (let* ((char (substring (car argv) 1 2))
- (kw (symbol->keyword char)))
- (cond
-
- ((member kw kw-opts)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (new-argv (if (= 0 (string-length rest-car))
- (cdr argv)
- (cons (string-append "-" rest-car) (cdr argv)))))
- (return kw #f new-argv)))
-
- ((member kw kw-args)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (arg (if (= 0 (string-length rest-car))
- (cadr argv)
- rest-car))
- (new-argv (if (= 0 (string-length rest-car))
- (cddr argv)
- (cdr argv))))
- (return kw arg new-argv)))
-
- (else (return 'usage-error kw argv)))))))
-
-(define (for-next-option proc argv kw-opts kw-args)
- (issue-deprecation-warning
- "`for-next-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (let loop ((argv argv))
- (get-option argv kw-opts kw-args
- (lambda (opt opt-arg argv)
- (and opt (proc opt opt-arg argv loop))))))
-
-(define (display-usage-report kw-desc)
- (issue-deprecation-warning
- "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (for-each
- (lambda (kw)
- (or (eq? (car kw) #t)
- (eq? (car kw) 'else)
- (let* ((opt-desc kw)
- (help (cadr opt-desc))
- (opts (car opt-desc))
- (opts-proper (if (string? (car opts)) (cdr opts) opts))
- (arg-name (if (string? (car opts))
- (string-append "<" (car opts) ">")
- ""))
- (left-part (string-append
- (with-output-to-string
- (lambda ()
- (map (lambda (x) (display (keyword->symbol x)) (display " "))
- opts-proper)))
- arg-name))
- (middle-part (if (and (< (string-length left-part) 30)
- (< (string-length help) 40))
- (make-string (- 30 (string-length left-part)) #\ )
- "\n\t")))
- (display left-part)
- (display middle-part)
- (display help)
- (newline))))
- kw-desc))
-
-(define (transform-usage-lambda cases)
- (issue-deprecation-warning
- "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (let* ((raw-usage (delq! 'else (map car cases)))
- (usage-sans-specials (map (lambda (x)
- (or (and (not (list? x)) x)
- (and (symbol? (car x)) #t)
- (and (boolean? (car x)) #t)
- x))
- raw-usage))
- (usage-desc (delq! #t usage-sans-specials))
- (kw-desc (map car usage-desc))
- (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
- (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
- (transmogrified-cases (map (lambda (case)
- (cons (let ((opts (car case)))
- (if (or (boolean? opts) (eq? 'else opts))
- opts
- (cond
- ((symbol? (car opts)) opts)
- ((boolean? (car opts)) opts)
- ((string? (caar opts)) (cdar opts))
- (else (car opts)))))
- (cdr case)))
- cases)))
- `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
- (lambda (%argv)
- (let %next-arg ((%argv %argv))
- (get-option %argv
- ',kw-opts
- ',kw-args
- (lambda (%opt %arg %new-argv)
- (case %opt
- ,@ transmogrified-cases))))))))
-
-
-
-;;; {collect}
-;;;
-;;; Similar to `begin' but returns a list of the results of all constituent
-;;; forms instead of the result of the last form.
-;;;
-
-(define-syntax collect
- (lambda (x)
- (issue-deprecation-warning
- "`collect' is deprecated. Define it yourself.")
- (syntax-case x ()
- ((_) #''())
- ((_ x x* ...)
- #'(let ((val x))
- (cons val (collect x* ...)))))))
-
-
-
-
-(define (assert-repl-silence v)
- (issue-deprecation-warning
- "`assert-repl-silence' has moved to `(ice-9 scm-style-repl)'.")
- ((@ (ice-9 scm-style-repl) assert-repl-silence) v))
-
-(define (assert-repl-print-unspecified v)
- (issue-deprecation-warning
- "`assert-repl-print-unspecified' has moved to `(ice-9 scm-style-repl)'.")
- ((@ (ice-9 scm-style-repl) assert-repl-print-unspecified) v))
-
-(define (assert-repl-verbosity v)
- (issue-deprecation-warning
- "`assert-repl-verbosity' has moved to `(ice-9 scm-style-repl)'.")
- ((@ (ice-9 scm-style-repl) assert-repl-verbosity) v))
-
-(define (set-repl-prompt! v)
- (issue-deprecation-warning
- "`set-repl-prompt!' is deprecated. Use `repl-default-prompt-set!' from
-the `(system repl common)' module.")
- ;; Avoid @, as when bootstrapping it will cause the (system repl common)
- ;; module to be loaded at expansion time, which eventually loads srfi-1, but
- ;; that fails due to an unbuilt supporting lib... grrrrrrrrr.
- ((module-ref (resolve-interface '(system repl common))
- 'repl-default-prompt-set!)
- v))
-
-(define (set-batch-mode?! arg)
- (cond
- (arg
- (issue-deprecation-warning
- "`set-batch-mode?!' is deprecated. Use `ensure-batch-mode!' instead.")
- (ensure-batch-mode!))
- (else
- (issue-deprecation-warning
- "`set-batch-mode?!' with an argument of `#f' is deprecated. Use the
-`*repl-stack*' fluid instead.")
- #t)))
-
-(define (repl read evaler print)
- (issue-deprecation-warning
- "`repl' is deprecated. Define it yourself.")
- (let loop ((source (read (current-input-port))))
- (print (evaler source))
- (loop (read (current-input-port)))))
-
-(define (pre-unwind-handler-dispatch key . args)
- (issue-deprecation-warning
- "`pre-unwind-handler-dispatch' is deprecated. Use
-`default-pre-unwind-handler' from `(ice-9 scm-style-repl)' directly.")
- (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
-
-(define (default-pre-unwind-handler key . args)
- (issue-deprecation-warning
- "`default-pre-unwind-handler' is deprecated. Use it from
-`(ice-9 scm-style-repl)' if you need it.")
- (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
-
-(define (handle-system-error key . args)
- (issue-deprecation-warning
- "`handle-system-error' is deprecated. Use it from
-`(ice-9 scm-style-repl)' if you need it.")
- (apply (@ (ice-9 scm-style-repl) handle-system-error) key args))
-
-(define-syntax stack-saved?
- (make-variable-transformer
- (lambda (x)
- (issue-deprecation-warning
- "`stack-saved?' is deprecated. Use it from
-`(ice-9 save-stack)' if you need it.")
- (syntax-case x (set!)
- ((set! id val)
- (identifier? #'id)
- #'(set! (@ (ice-9 save-stack) stack-saved?) val))
- (id
- (identifier? #'id)
- #'(@ (ice-9 save-stack) stack-saved?))))))
-
-(define-syntax the-last-stack
- (lambda (x)
- (issue-deprecation-warning
- "`the-last-stack' is deprecated. Use it from `(ice-9 save-stack)'
-if you need it.")
- (syntax-case x ()
- (id
- (identifier? #'id)
- #'(@ (ice-9 save-stack) the-last-stack)))))
-
-(define (save-stack . args)
- (issue-deprecation-warning
- "`save-stack' is deprecated. Use it from `(ice-9 save-stack)' if you need
-it.")
- (apply (@ (ice-9 save-stack) save-stack) args))
-
-(define (named-module-use! user usee)
- (issue-deprecation-warning
- "`named-module-use!' is deprecated. Define it yourself if you need it.")
- (module-use! (resolve-module user) (resolve-interface usee)))
-
-(define (top-repl)
- (issue-deprecation-warning
- "`top-repl' has moved to the `(ice-9 top-repl)' module.")
- ((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl)))
-
-(set! debug-enable
- (let ((debug-enable debug-enable))
- (lambda opts
- (if (memq 'debug opts)
- (begin
- (issue-deprecation-warning
- "`(debug-enable 'debug)' is obsolete and has no effect."
- "Remove it from your code.")
- (apply debug-enable (delq 'debug opts)))
- (apply debug-enable opts)))))
-
-(define (turn-on-debugging)
- (issue-deprecation-warning
- "`(turn-on-debugging)' is obsolete and usually has no effect."
- "Debugging capabilities are present by default.")
- (debug-enable 'backtrace)
- (read-enable 'positions))
-
-(define (read-hash-procedures-warning)
- (issue-deprecation-warning
- "`read-hash-procedures' is deprecated."
- "Use the fluid `%read-hash-procedures' instead."))
-
-(define-syntax read-hash-procedures
- (identifier-syntax
- (_
- (begin (read-hash-procedures-warning)
- (fluid-ref %read-hash-procedures)))
- ((set! _ expr)
- (begin (read-hash-procedures-warning)
- (fluid-set! %read-hash-procedures expr)))))
-
-(define (process-define-module args)
- (define (missing kw)
- (error "missing argument to define-module keyword" kw))
- (define (unrecognized arg)
- (error "unrecognized define-module argument" arg))
-
- (issue-deprecation-warning
- "`process-define-module' is deprecated. Use `define-module*' instead.")
-
- (let ((name (car args))
- (filename #f)
- (pure? #f)
- (version #f)
- (system? #f)
- (duplicates '())
- (transformer #f))
- (let loop ((kws (cdr args))
- (imports '())
- (exports '())
- (re-exports '())
- (replacements '())
- (autoloads '()))
- (if (null? kws)
- (define-module* name
- #:filename filename #:pure pure? #:version version
- #:duplicates duplicates #:transformer transformer
- #:imports (reverse! imports)
- #:exports exports
- #:re-exports re-exports
- #:replacements replacements
- #:autoloads autoloads)
- (case (car kws)
- ((#:use-module #:use-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (cond
- ((equal? (cadr kws) '(ice-9 syncase))
- (issue-deprecation-warning
- "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- (else
- (let ((iface-spec (cadr kws)))
- (if (eq? (car kws) #:use-syntax)
- (set! transformer iface-spec))
- (loop (cddr kws)
- (cons iface-spec imports) exports re-exports
- replacements autoloads)))))
- ((#:autoload)
- (or (and (pair? (cdr kws)) (pair? (cddr kws)))
- (missing (car kws)))
- (let ((name (cadr kws))
- (bindings (caddr kws)))
- (loop (cdddr kws)
- imports exports re-exports
- replacements (cons* name bindings autoloads))))
- ((#:no-backtrace)
- ;; FIXME: deprecate?
- (set! system? #t)
- (loop (cdr kws)
- imports exports re-exports replacements autoloads))
- ((#:pure)
- (set! pure? #t)
- (loop (cdr kws)
- imports exports re-exports replacements autoloads))
- ((#:version)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (set! version (cadr kws))
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- ((#:duplicates)
- (if (not (pair? (cdr kws)))
- (missing (car kws)))
- (set! duplicates (cadr kws))
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- ((#:export #:export-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (loop (cddr kws)
- imports (append exports (cadr kws)) re-exports
- replacements autoloads))
- ((#:re-export #:re-export-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (loop (cddr kws)
- imports exports (append re-exports (cadr kws))
- replacements autoloads))
- ((#:replace #:replace-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (loop (cddr kws)
- imports exports re-exports
- (append replacements (cadr kws)) autoloads))
- ((#:filename)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (set! filename (cadr kws))
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- (else
- (unrecognized kws)))))))
-
-(define-syntax fluid-let-syntax
- (lambda (x)
- (issue-deprecation-warning
- "`fluid-let-syntax' is deprecated. Use syntax parameters instead.")
- (syntax-case x ()
- ((_ ((k v) ...) body0 body ...)
- #'(syntax-parameterize ((k v) ...)
- body0 body ...)))))
-
-(define (close-io-port port)
- (issue-deprecation-warning
- "`close-io-port' is deprecated. Use `close-port' instead.")
- (close-port port))
-
-(define (set-system-module! m s)
- (issue-deprecation-warning
- "`set-system-module!' is deprecated. There is no need to use it.")
- (set-procedure-property! (module-eval-closure m) 'system-module s))
-
-(set! module-eval-closure
- (lambda (m)
- (issue-deprecation-warning
- "`module-eval-closure' is deprecated. Use module-variable or module-define! instead.")
- (standard-eval-closure m)))
-
-;; Legacy definition. We can't make it identifier-syntax yet though,
-;; because compiled code might rely on it.
-(define char-code-limit 256)
+ #:export ())
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 554c88e56..90bc25457 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -424,14 +424,11 @@
(set-procedure-property! proc 'documentation docstring))
proc))
- (('begin (first . rest))
- (let lp ((first first) (rest rest))
- (if (null? rest)
- (eval first env)
- (begin
- (eval first env)
- (lp (car rest) (cdr rest))))))
-
+ (('seq (head . tail))
+ (begin
+ (eval head env)
+ (eval tail env)))
+
(('lexical-set! (n . x))
(let ((val (eval x env)))
(list-set! env n val)))
diff --git a/module/ice-9/local-eval.scm b/module/ice-9/local-eval.scm
index 28f30b991..493dbed0d 100644
--- a/module/ice-9/local-eval.scm
+++ b/module/ice-9/local-eval.scm
@@ -180,7 +180,11 @@
t)
patterns))))
(else
- (error "what" type val))))))))))
+ ;; Interestingly, this case can include globals (and
+ ;; global macros), now that Guile tracks which globals it
+ ;; introduces. Not sure what to do here! For now, punt.
+ ;;
+ (lp ids capture formals wrappers patterns))))))))))
(define-syntax the-environment
(lambda (x)
diff --git a/module/ice-9/peg.scm b/module/ice-9/peg.scm
new file mode 100644
index 000000000..4e03131cd
--- /dev/null
+++ b/module/ice-9/peg.scm
@@ -0,0 +1,42 @@
+;;;; peg.scm --- Parsing Expression Grammar (PEG) parser generator
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 peg)
+ #:use-module (ice-9 peg codegen)
+ #:use-module (ice-9 peg string-peg)
+ ;; Note: the most important effect of using string-peg is not whatever
+ ;; functions it exports, but the fact that it adds a new handler to
+ ;; peg-sexp-compile.
+ #:use-module (ice-9 peg simplify-tree)
+ #:use-module (ice-9 peg using-parsers)
+ #:use-module (ice-9 peg cache)
+ #:re-export (define-peg-pattern
+ define-peg-string-patterns
+ match-pattern
+ search-for-pattern
+ compile-peg-pattern
+ keyword-flatten
+ context-flatten
+ peg:start
+ peg:end
+ peg:string
+ peg:tree
+ peg:substring
+ peg-record?))
+
diff --git a/module/ice-9/peg/cache.scm b/module/ice-9/peg/cache.scm
new file mode 100644
index 000000000..f45432b35
--- /dev/null
+++ b/module/ice-9/peg/cache.scm
@@ -0,0 +1,45 @@
+;;;; cache.scm --- cache the results of parsing
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 peg cache)
+ #:export (cg-cached-parser))
+
+;; The results of parsing using a nonterminal are cached. Think of it like a
+;; hash with no conflict resolution. Process for deciding on the cache size
+;; wasn't very scientific; just ran the benchmarks and stopped a little after
+;; the point of diminishing returns on my box.
+(define *cache-size* 512)
+
+(define (make-cache)
+ (make-vector *cache-size* #f))
+
+;; given a syntax object which is a parser function, returns syntax
+;; which, if evaluated, will become a parser function that uses a cache.
+(define (cg-cached-parser parser)
+ #`(let ((cache (make-cache)))
+ (lambda (str strlen at)
+ (let* ((vref (vector-ref cache (modulo at *cache-size*))))
+ ;; Check to see whether the value is cached.
+ (if (and vref (eq? (car vref) str) (= (cadr vref) at))
+ (caddr vref);; If it is return it.
+ (let ((fres ;; Else calculate it and cache it.
+ (#,parser str strlen at)))
+ (vector-set! cache (modulo at *cache-size*)
+ (list str at fres))
+ fres))))))
diff --git a/module/ice-9/peg/codegen.scm b/module/ice-9/peg/codegen.scm
new file mode 100644
index 000000000..d80c3e849
--- /dev/null
+++ b/module/ice-9/peg/codegen.scm
@@ -0,0 +1,359 @@
+;;;; codegen.scm --- code generation for composable parsers
+;;;;
+;;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 peg codegen)
+ #:export (compile-peg-pattern wrap-parser-for-users add-peg-compiler!)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (system base pmatch))
+
+(define-syntax single?
+ (syntax-rules ()
+ "Return #t if X is a list of one element."
+ ((_ x)
+ (pmatch x
+ ((_) #t)
+ (else #f)))))
+
+(define-syntax single-filter
+ (syntax-rules ()
+ "If EXP is a list of one element, return the element. Otherwise
+return EXP."
+ ((_ exp)
+ (pmatch exp
+ ((,elt) elt)
+ (,elts elts)))))
+
+(define-syntax push-not-null!
+ (syntax-rules ()
+ "If OBJ is non-null, push it onto LST, otherwise do nothing."
+ ((_ lst obj)
+ (if (not (null? obj))
+ (push! lst obj)))))
+
+(define-syntax push!
+ (syntax-rules ()
+ "Push an object onto a list."
+ ((_ lst obj)
+ (set! lst (cons obj lst)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; CODE GENERATORS
+;; These functions generate scheme code for parsing PEGs.
+;; Conventions:
+;; accum: (all name body none)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Code we generate will have a certain return structure depending on how we're
+;; accumulating (the ACCUM variable).
+(define (cg-generic-ret accum name body-uneval at)
+ ;; name, body-uneval and at are syntax
+ #`(let ((body #,body-uneval))
+ #,(cond
+ ((and (eq? accum 'all) name)
+ #`(list #,at
+ (cond
+ ((not (list? body)) (list '#,name body))
+ ((null? body) '#,name)
+ ((symbol? (car body)) (list '#,name body))
+ (else (cons '#,name body)))))
+ ((eq? accum 'name)
+ #`(list #,at '#,name))
+ ((eq? accum 'body)
+ #`(list #,at
+ (cond
+ ((single? body) (car body))
+ (else body))))
+ ((eq? accum 'none)
+ #`(list #,at '()))
+ (else
+ (begin
+ (pretty-print `(cg-generic-ret-error ,accum ,name ,body-uneval ,at))
+ (pretty-print "Defaulting to accum of none.\n")
+ #`(list #,at '()))))))
+
+;; The short name makes the formatting below much easier to read.
+(define cggr cg-generic-ret)
+
+;; Generates code that matches a particular string.
+;; E.g.: (cg-string syntax "abc" 'body)
+(define (cg-string pat accum)
+ (let ((plen (string-length pat)))
+ #`(lambda (str len pos)
+ (let ((end (+ pos #,plen)))
+ (and (<= end len)
+ (string= str #,pat pos end)
+ #,(case accum
+ ((all) #`(list end (list 'cg-string #,pat)))
+ ((name) #`(list end 'cg-string))
+ ((body) #`(list end #,pat))
+ ((none) #`(list end '()))
+ (else (error "bad accum" accum))))))))
+
+;; Generates code for matching any character.
+;; E.g.: (cg-peg-any syntax 'body)
+(define (cg-peg-any accum)
+ #`(lambda (str len pos)
+ (and (< pos len)
+ #,(case accum
+ ((all) #`(list (1+ pos)
+ (list 'cg-peg-any (substring str pos (1+ pos)))))
+ ((name) #`(list (1+ pos) 'cg-peg-any))
+ ((body) #`(list (1+ pos) (substring str pos (1+ pos))))
+ ((none) #`(list (1+ pos) '()))
+ (else (error "bad accum" accum))))))
+
+;; Generates code for matching a range of characters between start and end.
+;; E.g.: (cg-range syntax #\a #\z 'body)
+(define (cg-range pat accum)
+ (syntax-case pat ()
+ ((start end)
+ (if (not (and (char? (syntax->datum #'start))
+ (char? (syntax->datum #'end))))
+ (error "range PEG should have characters after it; instead got"
+ #'start #'end))
+ #`(lambda (str len pos)
+ (and (< pos len)
+ (let ((c (string-ref str pos)))
+ (and (char>=? c start)
+ (char<=? c end)
+ #,(case accum
+ ((all) #`(list (1+ pos) (list 'cg-range (string c))))
+ ((name) #`(list (1+ pos) 'cg-range))
+ ((body) #`(list (1+ pos) (string c)))
+ ((none) #`(list (1+ pos) '()))
+ (else (error "bad accum" accum))))))))))
+
+;; Generate code to match a pattern and do nothing with the result
+(define (cg-ignore pat accum)
+ (syntax-case pat ()
+ ((inner)
+ (compile-peg-pattern #'inner 'none))))
+
+(define (cg-capture pat accum)
+ (syntax-case pat ()
+ ((inner)
+ (compile-peg-pattern #'inner 'body))))
+
+;; Filters the accum argument to compile-peg-pattern for buildings like string
+;; literals (since we don't want to tag them with their name if we're doing an
+;; "all" accum).
+(define (builtin-accum-filter accum)
+ (cond
+ ((eq? accum 'all) 'body)
+ ((eq? accum 'name) 'name)
+ ((eq? accum 'body) 'body)
+ ((eq? accum 'none) 'none)))
+(define baf builtin-accum-filter)
+
+;; Top-level function builder for AND. Reduces to a call to CG-AND-INT.
+(define (cg-and clauses accum)
+ #`(lambda (str len pos)
+ (let ((body '()))
+ #,(cg-and-int clauses (baf accum) #'str #'len #'pos #'body))))
+
+;; Internal function builder for AND (calls itself).
+(define (cg-and-int clauses accum str strlen at body)
+ (syntax-case clauses ()
+ (()
+ (cggr accum 'cg-and #`(reverse #,body) at))
+ ((first rest ...)
+ #`(let ((res (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at)))
+ (and res
+ ;; update AT and BODY then recurse
+ (let ((newat (car res))
+ (newbody (cadr res)))
+ (set! #,at newat)
+ (push-not-null! #,body (single-filter newbody))
+ #,(cg-and-int #'(rest ...) accum str strlen at body)))))))
+
+;; Top-level function builder for OR. Reduces to a call to CG-OR-INT.
+(define (cg-or clauses accum)
+ #`(lambda (str len pos)
+ #,(cg-or-int clauses (baf accum) #'str #'len #'pos)))
+
+;; Internal function builder for OR (calls itself).
+(define (cg-or-int clauses accum str strlen at)
+ (syntax-case clauses ()
+ (()
+ #f)
+ ((first rest ...)
+ #`(or (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at)
+ #,(cg-or-int #'(rest ...) accum str strlen at)))))
+
+(define (cg-* args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#t)
+ (lp new-end count)
+ (let ((success #,#t))
+ #,#`(and success
+ #,(cggr (baf accum) 'cg-body
+ #'(reverse body) #'new-end)))))))))))
+
+(define (cg-+ args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#t)
+ (lp new-end count)
+ (let ((success #,#'(>= count 1)))
+ #,#`(and success
+ #,(cggr (baf accum) 'cg-body
+ #'(reverse body) #'new-end)))))))))))
+
+(define (cg-? args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#'(< count 1))
+ (lp new-end count)
+ (let ((success #,#t))
+ #,#`(and success
+ #,(cggr (baf accum) 'cg-body
+ #'(reverse body) #'new-end)))))))))))
+
+(define (cg-followed-by args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#'(< count 1))
+ (lp new-end count)
+ (let ((success #,#'(= count 1)))
+ #,#`(and success
+ #,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
+
+(define (cg-not-followed-by args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#'(< count 1))
+ (lp new-end count)
+ (let ((success #,#'(= count 1)))
+ #,#`(if success
+ #f
+ #,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
+
+;; Association list of functions to handle different expressions as PEGs
+(define peg-compiler-alist '())
+
+(define (add-peg-compiler! symbol function)
+ (set! peg-compiler-alist
+ (assq-set! peg-compiler-alist symbol function)))
+
+(add-peg-compiler! 'range cg-range)
+(add-peg-compiler! 'ignore cg-ignore)
+(add-peg-compiler! 'capture cg-capture)
+(add-peg-compiler! 'and cg-and)
+(add-peg-compiler! 'or cg-or)
+(add-peg-compiler! '* cg-*)
+(add-peg-compiler! '+ cg-+)
+(add-peg-compiler! '? cg-?)
+(add-peg-compiler! 'followed-by cg-followed-by)
+(add-peg-compiler! 'not-followed-by cg-not-followed-by)
+
+;; Takes an arbitrary expressions and accumulation variable, then parses it.
+;; E.g.: (compile-peg-pattern syntax '(and "abc" (or "-" (range #\a #\z))) 'all)
+(define (compile-peg-pattern pat accum)
+ (syntax-case pat (peg-any)
+ (peg-any
+ (cg-peg-any (baf accum)))
+ (sym (identifier? #'sym) ;; nonterminal
+ #'sym)
+ (str (string? (syntax->datum #'str)) ;; literal string
+ (cg-string (syntax->datum #'str) (baf accum)))
+ ((name . args) (let* ((nm (syntax->datum #'name))
+ (entry (assq-ref peg-compiler-alist nm)))
+ (if entry
+ (entry #'args accum)
+ (error "Bad peg form" nm #'args
+ "Not one of" (map car peg-compiler-alist)))))))
+
+;; Packages the results of a parser
+(define (wrap-parser-for-users for-syntax parser accumsym s-syn)
+ #`(lambda (str strlen at)
+ (let ((res (#,parser str strlen at)))
+ ;; Try to match the nonterminal.
+ (if res
+ ;; If we matched, do some post-processing to figure out
+ ;; what data to propagate upward.
+ (let ((at (car res))
+ (body (cadr res)))
+ #,(cond
+ ((eq? accumsym 'name)
+ #`(list at '#,s-syn))
+ ((eq? accumsym 'all)
+ #`(list (car res)
+ (cond
+ ((not (list? body))
+ (list '#,s-syn body))
+ ((null? body) '#,s-syn)
+ ((symbol? (car body))
+ (list '#,s-syn body))
+ (else (cons '#,s-syn body)))))
+ ((eq? accumsym 'none) #`(list (car res) '()))
+ (else #`(begin res))))
+ ;; If we didn't match, just return false.
+ #f))))
diff --git a/module/ice-9/peg/simplify-tree.scm b/module/ice-9/peg/simplify-tree.scm
new file mode 100644
index 000000000..4c781a191
--- /dev/null
+++ b/module/ice-9/peg/simplify-tree.scm
@@ -0,0 +1,97 @@
+;;;; simplify-tree.scm --- utility functions for the PEG parser
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 peg simplify-tree)
+ #:export (keyword-flatten context-flatten string-collapse)
+ #:use-module (system base pmatch))
+
+(define-syntax single?
+ (syntax-rules ()
+ "Return #t if X is a list of one element."
+ ((_ x)
+ (pmatch x
+ ((_) #t)
+ (else #f)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Is everything in LST true?
+(define (andlst lst)
+ (or (null? lst)
+ (and (car lst) (andlst (cdr lst)))))
+
+;; Is LST a list of strings?
+(define (string-list? lst)
+ (and (list? lst) (not (null? lst))
+ (andlst (map string? lst))))
+
+;; Groups all strings that are next to each other in LST. Used in
+;; STRING-COLLAPSE.
+(define (string-group lst)
+ (if (not (list? lst))
+ lst
+ (if (null? lst)
+ '()
+ (let ((next (string-group (cdr lst))))
+ (if (not (string? (car lst)))
+ (cons (car lst) next)
+ (if (and (not (null? next))
+ (list? (car next))
+ (string? (caar next)))
+ (cons (cons (car lst) (car next)) (cdr next))
+ (cons (list (car lst)) next)))))))
+
+
+;; Collapses all the string in LST.
+;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef")
+(define (string-collapse lst)
+ (if (list? lst)
+ (let ((res (map (lambda (x) (if (string-list? x)
+ (apply string-append x)
+ x))
+ (string-group (map string-collapse lst)))))
+ (if (single? res) (car res) res))
+ lst))
+
+;; If LST is an atom, return (list LST), else return LST.
+(define (mklst lst)
+ (if (not (list? lst)) (list lst) lst))
+
+;; Takes a list and "flattens" it, using the predicate TST to know when to stop
+;; instead of terminating on atoms (see tutorial).
+(define (context-flatten tst lst)
+ (if (or (not (list? lst)) (null? lst))
+ lst
+ (if (tst lst)
+ (list lst)
+ (apply append
+ (map (lambda (x) (mklst (context-flatten tst x)))
+ lst)))))
+
+;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to
+;; know when to stop at (see tutorial).
+(define (keyword-flatten keyword-lst lst)
+ (context-flatten
+ (lambda (x)
+ (if (or (not (list? x)) (null? x))
+ #t
+ (member (car x) keyword-lst)))
+ lst))
diff --git a/module/ice-9/peg/string-peg.scm b/module/ice-9/peg/string-peg.scm
new file mode 100644
index 000000000..45ed14bb1
--- /dev/null
+++ b/module/ice-9/peg/string-peg.scm
@@ -0,0 +1,273 @@
+;;;; string-peg.scm --- representing PEG grammars as strings
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 peg string-peg)
+ #:export (peg-as-peg
+ define-peg-string-patterns
+ peg-grammar)
+ #:use-module (ice-9 peg using-parsers)
+ #:use-module (ice-9 peg codegen)
+ #:use-module (ice-9 peg simplify-tree))
+
+;; Gets the left-hand depth of a list.
+(define (depth lst)
+ (if (or (not (list? lst)) (null? lst))
+ 0
+ (+ 1 (depth (car lst)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; Parse string PEGs using sexp PEGs.
+;; See the variable PEG-AS-PEG for an easier-to-read syntax.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Grammar for PEGs in PEG grammar.
+(define peg-as-peg
+"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+
+pattern <-- alternative (SLASH sp alternative)*
+alternative <-- ([!&]? sp suffix)+
+suffix <-- primary ([*+?] sp)*
+primary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<'
+literal <-- ['] (!['] .)* ['] sp
+charclass <-- LB (!']' (CCrange / CCsingle))* RB sp
+CCrange <-- . '-' .
+CCsingle <-- .
+nonterminal <-- [a-zA-Z0-9-]+ sp
+sp < [ \t\n]*
+SLASH < '/'
+LB < '['
+RB < ']'
+")
+
+(define-syntax define-sexp-parser
+ (lambda (x)
+ (syntax-case x ()
+ ((_ sym accum pat)
+ (let* ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))
+ (accumsym (syntax->datum #'accum))
+ (syn (wrap-parser-for-users x matchf accumsym #'sym)))
+ #`(define sym #,syn))))))
+
+(define-sexp-parser peg-grammar all
+ (+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern)))
+(define-sexp-parser peg-pattern all
+ (and peg-alternative
+ (* (and (ignore "/") peg-sp peg-alternative))))
+(define-sexp-parser peg-alternative all
+ (+ (and (? (or "!" "&")) peg-sp peg-suffix)))
+(define-sexp-parser peg-suffix all
+ (and peg-primary (* (and (or "*" "+" "?") peg-sp))))
+(define-sexp-parser peg-primary all
+ (or (and "(" peg-sp peg-pattern ")" peg-sp)
+ (and "." peg-sp)
+ peg-literal
+ peg-charclass
+ (and peg-nonterminal (not-followed-by "<"))))
+(define-sexp-parser peg-literal all
+ (and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp))
+(define-sexp-parser peg-charclass all
+ (and (ignore "[")
+ (* (and (not-followed-by "]")
+ (or charclass-range charclass-single)))
+ (ignore "]")
+ peg-sp))
+(define-sexp-parser charclass-range all (and peg-any "-" peg-any))
+(define-sexp-parser charclass-single all peg-any)
+(define-sexp-parser peg-nonterminal all
+ (and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp))
+(define-sexp-parser peg-sp none
+ (* (or " " "\t" "\n")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PARSE STRING PEGS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Takes a string representing a PEG grammar and returns syntax that
+;; will define all of the nonterminals in the grammar with equivalent
+;; PEG s-expressions.
+(define (peg-parser str for-syntax)
+ (let ((parsed (match-pattern peg-grammar str)))
+ (if (not parsed)
+ (begin
+ ;; (display "Invalid PEG grammar!\n")
+ #f)
+ (let ((lst (peg:tree parsed)))
+ (cond
+ ((or (not (list? lst)) (null? lst))
+ lst)
+ ((eq? (car lst) 'peg-grammar)
+ #`(begin
+ #,@(map (lambda (x) (peg-nonterm->defn x for-syntax))
+ (context-flatten (lambda (lst) (<= (depth lst) 2))
+ (cdr lst))))))))))
+
+;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
+;; defines all the appropriate nonterminals.
+(define-syntax define-peg-string-patterns
+ (lambda (x)
+ (syntax-case x ()
+ ((_ str)
+ (peg-parser (syntax->datum #'str) x)))))
+
+;; lst has format (nonterm grabber pattern), where
+;; nonterm is a symbol (the name of the nonterminal),
+;; grabber is a string (either "<", "<-" or "<--"), and
+;; pattern is the parse of a PEG pattern expressed as as string.
+(define (peg-nonterm->defn lst for-syntax)
+ (let* ((nonterm (car lst))
+ (grabber (cadr lst))
+ (pattern (caddr lst))
+ (nonterm-name (datum->syntax for-syntax
+ (string->symbol (cadr nonterm)))))
+ #`(define-peg-pattern #,nonterm-name
+ #,(cond
+ ((string=? grabber "<--") (datum->syntax for-syntax 'all))
+ ((string=? grabber "<-") (datum->syntax for-syntax 'body))
+ (else (datum->syntax for-syntax 'none)))
+ #,(compressor (peg-pattern->defn pattern for-syntax) for-syntax))))
+
+;; lst has format ('peg-pattern ...).
+;; After the context-flatten, (cdr lst) has format
+;; (('peg-alternative ...) ...), where the outer list is a collection
+;; of elements from a '/' alternative.
+(define (peg-pattern->defn lst for-syntax)
+ #`(or #,@(map (lambda (x) (peg-alternative->defn x for-syntax))
+ (context-flatten (lambda (x) (eq? (car x) 'peg-alternative))
+ (cdr lst)))))
+
+;; lst has format ('peg-alternative ...).
+;; After the context-flatten, (cdr lst) has the format
+;; (item ...), where each item has format either ("!" ...), ("&" ...),
+;; or ('peg-suffix ...).
+(define (peg-alternative->defn lst for-syntax)
+ #`(and #,@(map (lambda (x) (peg-body->defn x for-syntax))
+ (context-flatten (lambda (x) (or (string? (car x))
+ (eq? (car x) 'peg-suffix)))
+ (cdr lst)))))
+
+;; lst has the format either
+;; ("!" ('peg-suffix ...)), ("&" ('peg-suffix ...)), or
+;; ('peg-suffix ...).
+(define (peg-body->defn lst for-syntax)
+ (cond
+ ((equal? (car lst) "&")
+ #`(followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
+ ((equal? (car lst) "!")
+ #`(not-followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
+ ((eq? (car lst) 'peg-suffix)
+ (peg-suffix->defn lst for-syntax))
+ (else `(peg-parse-body-fail ,lst))))
+
+;; lst has format ('peg-suffix <peg-primary> (? (/ "*" "?" "+")))
+(define (peg-suffix->defn lst for-syntax)
+ (let ((inner-defn (peg-primary->defn (cadr lst) for-syntax)))
+ (cond
+ ((null? (cddr lst))
+ inner-defn)
+ ((equal? (caddr lst) "*")
+ #`(* #,inner-defn))
+ ((equal? (caddr lst) "?")
+ #`(? #,inner-defn))
+ ((equal? (caddr lst) "+")
+ #`(+ #,inner-defn)))))
+
+;; Parse a primary.
+(define (peg-primary->defn lst for-syntax)
+ (let ((el (cadr lst)))
+ (cond
+ ((list? el)
+ (cond
+ ((eq? (car el) 'peg-literal)
+ (peg-literal->defn el for-syntax))
+ ((eq? (car el) 'peg-charclass)
+ (peg-charclass->defn el for-syntax))
+ ((eq? (car el) 'peg-nonterminal)
+ (datum->syntax for-syntax (string->symbol (cadr el))))))
+ ((string? el)
+ (cond
+ ((equal? el "(")
+ (peg-pattern->defn (caddr lst) for-syntax))
+ ((equal? el ".")
+ (datum->syntax for-syntax 'peg-any))
+ (else (datum->syntax for-syntax
+ `(peg-parse-any unknown-string ,lst)))))
+ (else (datum->syntax for-syntax
+ `(peg-parse-any unknown-el ,lst))))))
+
+;; Trims characters off the front and end of STR.
+;; (trim-1chars "'ab'") -> "ab"
+(define (trim-1chars str) (substring str 1 (- (string-length str) 1)))
+
+;; Parses a literal.
+(define (peg-literal->defn lst for-syntax)
+ (datum->syntax for-syntax (trim-1chars (cadr lst))))
+
+;; Parses a charclass.
+(define (peg-charclass->defn lst for-syntax)
+ #`(or
+ #,@(map
+ (lambda (cc)
+ (cond
+ ((eq? (car cc) 'charclass-range)
+ #`(range #,(datum->syntax
+ for-syntax
+ (string-ref (cadr cc) 0))
+ #,(datum->syntax
+ for-syntax
+ (string-ref (cadr cc) 2))))
+ ((eq? (car cc) 'charclass-single)
+ (datum->syntax for-syntax (cadr cc)))))
+ (context-flatten
+ (lambda (x) (or (eq? (car x) 'charclass-range)
+ (eq? (car x) 'charclass-single)))
+ (cdr lst)))))
+
+;; Compresses a list to save the optimizer work.
+;; e.g. (or (and a)) -> a
+(define (compressor-core lst)
+ (if (or (not (list? lst)) (null? lst))
+ lst
+ (cond
+ ((and (or (eq? (car lst) 'or) (eq? (car lst) 'and))
+ (null? (cddr lst)))
+ (compressor-core (cadr lst)))
+ ((and (eq? (car lst) 'body)
+ (eq? (cadr lst) 'lit)
+ (eq? (cadddr lst) 1))
+ (compressor-core (caddr lst)))
+ (else (map compressor-core lst)))))
+
+(define (compressor syn for-syntax)
+ (datum->syntax for-syntax
+ (compressor-core (syntax->datum syn))))
+
+;; Builds a lambda-expressions for the pattern STR using accum.
+(define (peg-string-compile args accum)
+ (syntax-case args ()
+ ((str-stx) (string? (syntax->datum #'str-stx))
+ (let ((string (syntax->datum #'str-stx)))
+ (compile-peg-pattern
+ (compressor
+ (peg-pattern->defn
+ (peg:tree (match-pattern peg-pattern string)) #'str-stx)
+ #'str-stx)
+ (if (eq? accum 'all) 'body accum))))
+ (else (error "Bad embedded PEG string" args))))
+
+(add-peg-compiler! 'peg peg-string-compile)
+
diff --git a/module/ice-9/peg/using-parsers.scm b/module/ice-9/peg/using-parsers.scm
new file mode 100644
index 000000000..076de2999
--- /dev/null
+++ b/module/ice-9/peg/using-parsers.scm
@@ -0,0 +1,116 @@
+;;;; using-parsers.scm --- utilities to make using parsers easier
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 peg using-parsers)
+ #:use-module (ice-9 peg simplify-tree)
+ #:use-module (ice-9 peg codegen)
+ #:use-module (ice-9 peg cache)
+ #:export (match-pattern define-peg-pattern search-for-pattern
+ prec make-prec peg:start peg:end peg:string
+ peg:tree peg:substring peg-record?))
+
+;;;
+;;; Helper Macros
+;;;
+
+(define-syntax until
+ (syntax-rules ()
+ "Evaluate TEST. If it is true, return its value. Otherwise,
+execute the STMTs and try again."
+ ((_ test stmt stmt* ...)
+ (let lp ()
+ (or test
+ (begin stmt stmt* ... (lp)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; FOR DEFINING AND USING NONTERMINALS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Parses STRING using NONTERM
+(define (match-pattern nonterm string)
+ ;; We copy the string before using it because it might have been modified
+ ;; in-place since the last time it was parsed, which would invalidate the
+ ;; cache. Guile uses copy-on-write for strings, so this is fast.
+ (let ((res (nonterm (string-copy string) (string-length string) 0)))
+ (if (not res)
+ #f
+ (make-prec 0 (car res) string (string-collapse (cadr res))))))
+
+;; Defines a new nonterminal symbol accumulating with ACCUM.
+(define-syntax define-peg-pattern
+ (lambda (x)
+ (syntax-case x ()
+ ((_ sym accum pat)
+ (let ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))
+ (accumsym (syntax->datum #'accum)))
+ ;; CODE is the code to parse the string if the result isn't cached.
+ (let ((syn (wrap-parser-for-users x matchf accumsym #'sym)))
+ #`(define sym #,(cg-cached-parser syn))))))))
+
+(define (peg-like->peg pat)
+ (syntax-case pat ()
+ (str (string? (syntax->datum #'str)) #'(peg str))
+ (else pat)))
+
+;; Searches through STRING for something that parses to PEG-MATCHER. Think
+;; regexp search.
+(define-syntax search-for-pattern
+ (lambda (x)
+ (syntax-case x ()
+ ((_ pattern string-uncopied)
+ (let ((pmsym (syntax->datum #'pattern)))
+ (let ((matcher (compile-peg-pattern (peg-like->peg #'pattern) 'body)))
+ ;; We copy the string before using it because it might have been
+ ;; modified in-place since the last time it was parsed, which would
+ ;; invalidate the cache. Guile uses copy-on-write for strings, so
+ ;; this is fast.
+ #`(let ((string (string-copy string-uncopied))
+ (strlen (string-length string-uncopied))
+ (at 0))
+ (let ((ret (until (or (>= at strlen)
+ (#,matcher string strlen at))
+ (set! at (+ at 1)))))
+ (if (eq? ret #t) ;; (>= at strlen) succeeded
+ #f
+ (let ((end (car ret))
+ (match (cadr ret)))
+ (make-prec
+ at end string
+ (string-collapse match))))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PMATCH STRUCTURE MUNGING
+;; Pretty self-explanatory.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define prec
+ (make-record-type "peg" '(start end string tree)))
+(define make-prec
+ (record-constructor prec '(start end string tree)))
+(define (peg:start pm)
+ (if pm ((record-accessor prec 'start) pm) #f))
+(define (peg:end pm)
+ (if pm ((record-accessor prec 'end) pm) #f))
+(define (peg:string pm)
+ (if pm ((record-accessor prec 'string) pm) #f))
+(define (peg:tree pm)
+ (if pm ((record-accessor prec 'tree) pm) #f))
+(define (peg:substring pm)
+ (if pm (substring (peg:string pm) (peg:start pm) (peg:end pm)) #f))
+(define peg-record? (record-predicate prec))
diff --git a/module/ice-9/poll.scm b/module/ice-9/poll.scm
index 2ba868748..1633dcbc5 100644
--- a/module/ice-9/poll.scm
+++ b/module/ice-9/poll.scm
@@ -1,6 +1,6 @@
;; poll
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -139,13 +139,7 @@
(off (pollfd-offset idx))
(fd (if (integer? fd-or-port)
fd-or-port
- (port->fdes fd-or-port))))
-
- (if (port? fd-or-port)
- ;; As we store the port in the fdset, there is no need to
- ;; increment the revealed count to prevent the fd from being
- ;; closed by a gc'd port.
- (release-port-handle fd-or-port))
+ (fileno fd-or-port))))
(ensure-pset-size! set (1+ idx))
(bytevector-s32-native-set! (pset-pollfds set) off fd)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 7b565dbe8..1225d92df 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -47,19 +47,22 @@
test
consequent
alternate)))
- (make-application
+ (make-call
(lambda (src proc args)
(make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
- (make-sequence
- (lambda (src exps)
- (make-struct (vector-ref %expanded-vtables 12) 0 src exps)))
+ (make-primcall
+ (lambda (src name args)
+ (make-struct (vector-ref %expanded-vtables 12) 0 src name args)))
+ (make-seq
+ (lambda (src head tail)
+ (make-struct (vector-ref %expanded-vtables 13) 0 src head tail)))
(make-lambda
(lambda (src meta body)
- (make-struct (vector-ref %expanded-vtables 13) 0 src meta body)))
+ (make-struct (vector-ref %expanded-vtables 14) 0 src meta body)))
(make-lambda-case
(lambda (src req opt rest kw inits gensyms body alternate)
(make-struct
- (vector-ref %expanded-vtables 14)
+ (vector-ref %expanded-vtables 15)
0
src
req
@@ -73,7 +76,7 @@
(make-let
(lambda (src names gensyms vals body)
(make-struct
- (vector-ref %expanded-vtables 15)
+ (vector-ref %expanded-vtables 16)
0
src
names
@@ -83,7 +86,7 @@
(make-letrec
(lambda (src in-order? names gensyms vals body)
(make-struct
- (vector-ref %expanded-vtables 16)
+ (vector-ref %expanded-vtables 17)
0
src
in-order?
@@ -94,7 +97,7 @@
(make-dynlet
(lambda (src fluids vals body)
(make-struct
- (vector-ref %expanded-vtables 17)
+ (vector-ref %expanded-vtables 18)
0
src
fluids
@@ -103,7 +106,7 @@
(lambda?
(lambda (x)
(and (struct? x)
- (eq? (struct-vtable x) (vector-ref %expanded-vtables 13)))))
+ (eq? (struct-vtable x) (vector-ref %expanded-vtables 14)))))
(lambda-meta (lambda (x) (struct-ref x 1)))
(set-lambda-meta! (lambda (x v) (struct-set! x 1 v)))
(top-level-eval-hook (lambda (x mod) (primitive-eval x)))
@@ -142,9 +145,9 @@
(if (not (assq 'name meta))
(set-lambda-meta! val (acons 'name name meta)))))))
(build-void (lambda (source) (make-void source)))
- (build-application
+ (build-call
(lambda (source fun-exp arg-exps)
- (make-application source fun-exp arg-exps)))
+ (make-call source fun-exp arg-exps)))
(build-conditional
(lambda (source test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp)))
@@ -206,15 +209,15 @@
(build-lambda-case
(lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case)))
- (build-primref
- (lambda (src name)
- (if (equal? (module-name (current-module)) '(guile))
- (make-toplevel-ref src name)
- (make-module-ref src '(guile) name #f))))
+ (build-primcall
+ (lambda (src name args) (make-primcall src name args)))
+ (build-primref (lambda (src name) (make-primitive-ref src name)))
(build-data (lambda (src exp) (make-const src exp)))
(build-sequence
(lambda (src exps)
- (if (null? (cdr exps)) (car exps) (make-sequence src exps))))
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(build-let
(lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps)
@@ -231,10 +234,7 @@
(list f-name)
(list f)
(list proc)
- (build-application
- src
- (build-lexical-reference 'fun src f-name f)
- val-exps))))))
+ (build-call src (build-lexical-reference 'fun src f-name f) val-exps))))))
(build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
(if (null? vars)
@@ -285,15 +285,9 @@
(if (null? r)
'()
(let ((a (car r)))
- (if (eq? (cadr a) 'macro)
+ (if (memq (cadr a) '(macro syntax-parameter))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
- (lookup
- (lambda (x r mod)
- (let ((t (assq x r)))
- (cond (t (cdr t))
- ((symbol? x) (or (get-global-definition-hook x mod) '(global)))
- (else '(displaced-lexical))))))
(global-extend
(lambda (type sym val) (put-global-definition-hook sym type val)))
(nonsymbol-id?
@@ -374,43 +368,53 @@
(eq? (car x) (car y))
(same-marks? (cdr x) (cdr y))))))
(id-var-name
- (lambda (id w)
+ (lambda (id w mod)
(letrec*
((search
- (lambda (sym subst marks)
+ (lambda (sym subst marks mod)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
+ (search sym (cdr subst) (cdr marks) mod)
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
+ (search-vector-rib sym subst marks symnames fst mod)
+ (search-list-rib sym subst marks symnames fst mod))))))))
(search-list-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0))
- (cond ((null? symnames) (search sym (cdr subst) marks))
+ (cond ((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (list-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (cdr symnames) (+ i 1)))
+ (values n marks))))
(else (f (cdr symnames) (+ i 1)))))))
(search-vector-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames)))
(let f ((i 0))
- (cond ((= i n) (search sym (cdr subst) marks))
+ (cond ((= i n) (search sym (cdr subst) marks mod))
((and (eq? (vector-ref symnames i) sym)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (vector-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1)))
+ (values n marks))))
(else (f (+ i 1)))))))))
- (cond ((symbol? id) (or (search id (cdr w) (car w)) id))
+ (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id))
((syntax-object? id)
- (let ((id (syntax-object-expression id)) (w1 (syntax-object-wrap id)))
+ (let ((id (syntax-object-expression id))
+ (w1 (syntax-object-wrap id))
+ (mod (syntax-object-module id)))
(let ((marks (join-marks (car w) (car w1))))
(call-with-values
- (lambda () (search id (cdr w) marks))
- (lambda (new-id marks) (or new-id (search id (cdr w1) marks) id))))))
+ (lambda () (search id (cdr w) marks mod))
+ (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id))))))
(else (syntax-violation 'id-var-name "invalid id" id))))))
(locally-bound-identifiers
(lambda (w mod)
@@ -447,20 +451,29 @@
results))))))))
(scan (cdr w) '()))))
(resolve-identifier
- (lambda (id w r mod)
+ (lambda (id w r mod resolve-syntax-parameters?)
(letrec*
- ((resolve-global
+ ((resolve-syntax-parameters
+ (lambda (b)
+ (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter))
+ (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b))))
+ b)))
+ (resolve-global
(lambda (var mod)
- (let ((b (or (get-global-definition-hook var mod) '(global))))
+ (let ((b (resolve-syntax-parameters
+ (or (get-global-definition-hook var mod) '(global)))))
(if (eq? (car b) 'global)
(values 'global var mod)
(values (car b) (cdr b) mod)))))
(resolve-lexical
(lambda (label mod)
- (let ((b (or (assq-ref r label) '(displaced-lexical))))
+ (let ((b (resolve-syntax-parameters
+ (or (assq-ref r label) '(displaced-lexical)))))
(values (car b) (cdr b) mod)))))
- (let ((n (id-var-name id w)))
- (cond ((symbol? n)
+ (let ((n (id-var-name id w mod)))
+ (cond ((syntax-object? n)
+ (resolve-identifier n w r mod resolve-syntax-parameters?))
+ ((symbol? n)
(resolve-global
n
(if (syntax-object? id) (syntax-object-module id) mod)))
@@ -477,9 +490,27 @@
(lambda (k) ((fluid-ref transformer-environment) k)))
(free-id=?
(lambda (i j)
- (and (eq? (let ((x i)) (if (syntax-object? x) (syntax-object-expression x) x))
- (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
- (eq? (id-var-name i '(())) (id-var-name j '(()))))))
+ (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
+ (mj (and (syntax-object? j) (syntax-object-module j)))
+ (ni (id-var-name i '(()) mi))
+ (nj (id-var-name j '(()) mj)))
+ (letrec*
+ ((id-module-binding
+ (lambda (id mod)
+ (module-variable
+ (if mod (resolve-module (cdr mod)) (current-module))
+ (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x))))))
+ (cond ((syntax-object? ni) (free-id=? ni j))
+ ((syntax-object? nj) (free-id=? i nj))
+ ((symbol? ni)
+ (and (eq? nj
+ (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
+ (let ((bi (id-module-binding i mi)))
+ (if bi
+ (eq? bi (id-module-binding j mj))
+ (and (not (id-module-binding j mj)) (eq? ni nj))))
+ (eq? (id-module-binding i mi) (id-module-binding j mj))))
+ (else (equal? ni nj)))))))
(bound-id=?
(lambda (i j)
(if (and (syntax-object? i) (syntax-object? j))
@@ -525,162 +556,151 @@
(cons first (dobody (cdr body) r w mod))))))))
(expand-top-sequence
(lambda (body r w s m esew mod)
- (letrec*
- ((scan (lambda (body r w s m esew mod exps)
- (if (null? body)
- exps
- (call-with-values
- (lambda ()
- (call-with-values
- (lambda ()
- (let ((e (car body)))
- (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
- (lambda (type value form e w s mod)
- (let ((key type))
- (cond ((memv key '(begin-form))
- (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_))))
- (if tmp-1
- (apply (lambda () exps) tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
- (if tmp-1
- (apply (lambda (e1 e2) (scan (cons e1 e2) r w s m esew mod exps))
- tmp-1)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp))))))
- ((memv key '(local-syntax-form))
- (expand-local-syntax
- value
- e
- r
- w
- s
- mod
- (lambda (body r w s mod) (scan body r w s m esew mod exps))))
- ((memv key '(eval-when-form))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
- (if tmp
- (apply (lambda (x e1 e2)
- (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
- (cond ((eq? m 'e)
- (if (memq 'eval when-list)
- (scan body
- r
- w
- s
- (if (memq 'expand when-list) 'c&e 'e)
- '(eval)
- mod
- exps)
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod))
- (values exps))))
- ((memq 'load when-list)
- (cond ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (scan body r w s 'c&e '(compile load) mod exps))
- ((memq m '(c c&e))
- (scan body r w s 'c '(load) mod exps))
- (else (values exps))))
- ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
+ (let* ((r (cons '("placeholder" placeholder) r))
+ (ribcage (make-ribcage '() '() '()))
+ (w (cons (car w) (cons ribcage (cdr w)))))
+ (letrec*
+ ((record-definition!
+ (lambda (id var)
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ (extend-ribcage!
+ ribcage
+ id
+ (cons (syntax-object-module id) (wrap var '((top)) mod))))))
+ (macro-introduced-identifier?
+ (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top)))))
+ (fresh-derived-name
+ (lambda (id orig-form)
+ (symbol-append
+ (syntax-object-expression id)
+ '-
+ (string->symbol
+ (number->string
+ (hash (syntax->datum orig-form) most-positive-fixnum)
+ 16)))))
+ (parse (lambda (body r w s m esew mod)
+ (let lp ((body body) (exps '()))
+ (if (null? body)
+ exps
+ (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps))))))
+ (parse1
+ (lambda (x r w s m esew mod)
+ (call-with-values
+ (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f))
+ (lambda (type value form e w s mod)
+ (let ((key type))
+ (cond ((memv key '(define-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (list (if (eq? m 'c&e)
+ (let ((x (build-global-definition s var (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda () (build-global-definition s var (expand e r w mod)))))))
+ ((memv key '(define-syntax-form define-syntax-parameter-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (let ((key m))
+ (cond ((memv key '(c))
+ (cond ((memq 'compile esew)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew) (list (lambda () e)) '())))
+ ((memq 'load esew)
+ (list (lambda () (expand-install-global var type (expand e r w mod)))))
+ (else '())))
+ ((memv key '(c&e))
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (list (lambda () e))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global var type (expand e r w mod))
+ mod))
+ '())))))
+ ((memv key '(begin-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+ (if tmp
+ (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax
+ value
+ e
+ r
+ w
+ s
+ mod
+ (lambda (forms r w s mod) (parse forms r w s m esew mod))))
+ ((memv key '(eval-when-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
+ (if tmp
+ (apply (lambda (x e1 e2)
+ (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
+ (letrec*
+ ((recurse (lambda (m esew) (parse body r w s m esew mod))))
+ (cond ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval))
+ (begin
+ (if (memq 'expand when-list)
(top-level-eval-hook
(expand-top-sequence body r w s 'e '(eval) mod)
- mod)
- (values exps))
- (else (values exps)))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))
- ((memv key '(define-syntax-form define-syntax-parameter-form))
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (let ((key m))
- (cond ((memv key '(c))
- (cond ((memq 'compile esew)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew) (values (cons e exps)) (values exps))))
- ((memq 'load esew)
- (values
- (cons (expand-install-global n (expand e r w mod)) exps)))
- (else (values exps))))
- ((memv key '(c&e))
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (values (cons e exps))))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (expand-install-global n (expand e r w mod))
- mod))
- (values exps))))))
- ((memv key '(define-form))
- (let* ((n (id-var-name value w)) (type (car (lookup n r mod))) (key type))
- (cond ((memv key '(global core macro module-ref))
- (if (and (memq m '(c c&e))
- (not (module-local-variable (current-module) n))
- (current-module))
- (let ((old (module-variable (current-module) n)))
- (if (and (variable? old) (variable-bound? old))
- (module-define! (current-module) n (variable-ref old))
- (module-add! (current-module) n (make-undefined-variable)))))
- (values
- (cons (if (eq? m 'c&e)
- (let ((x (build-global-definition s n (expand e r w mod))))
- (top-level-eval-hook x mod)
- x)
- (lambda () (build-global-definition s n (expand e r w mod))))
- exps)))
- ((memv key '(displaced-lexical))
- (syntax-violation
- #f
- "identifier out of context"
- (source-wrap form w s mod)
- (wrap value w mod)))
- (else
- (syntax-violation
- #f
- "cannot define keyword at top level"
- (source-wrap form w s mod)
- (wrap value w mod))))))
- (else
- (values
- (cons (if (eq? m 'c&e)
- (let ((x (expand-expr type value form e r w s mod)))
- (top-level-eval-hook x mod)
- x)
- (lambda () (expand-expr type value form e r w s mod)))
- exps))))))))
- (lambda (exps) (scan (cdr body) r w s m esew mod exps)))))))
- (call-with-values
- (lambda () (scan body r w s m esew mod '()))
- (lambda (exps)
- (if (null? exps)
- (build-void s)
- (build-sequence
- s
- (let lp ((in exps) (out '()))
- (if (null? in)
- out
- (let ((e (car in)))
- (lp (cdr in) (cons (if (procedure? e) (e) e) out))))))))))))
+ mod))
+ '())))
+ ((memq 'load when-list)
+ (cond ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (recurse 'c&e '(compile load)))
+ ((memq m '(c c&e)) (recurse 'c '(load)))
+ (else '())))
+ ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ '())
+ (else '())))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
+ (else
+ (list (if (eq? m 'c&e)
+ (let ((x (expand-expr type value form e r w s mod)))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda () (expand-expr type value form e r w s mod))))))))))))
+ (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod)))))
+ (if (null? exps) (build-void s) (build-sequence s exps)))))))
(expand-install-global
- (lambda (name e)
+ (lambda (name type e)
(build-global-definition
#f
name
- (build-application
+ (build-primcall
#f
- (build-primref #f 'make-syntax-transformer)
- (list (build-data #f name) (build-data #f 'macro) e)))))
+ 'make-syntax-transformer
+ (if (eq? type 'define-syntax-parameter-form)
+ (list (build-data #f name)
+ (build-data #f 'syntax-parameter)
+ (build-primcall #f 'list (list e)))
+ (list (build-data #f name) (build-data #f 'macro) e))))))
(parse-when-list
(lambda (e when-list)
(let ((result (strip when-list '(()))))
@@ -691,24 +711,23 @@
(syntax-type
(lambda (e r w s rib mod for-car?)
(cond ((symbol? e)
- (let* ((n (id-var-name e w))
- (b (lookup n r mod))
- (type (car b))
- (key type))
- (cond ((memv key '(lexical)) (values type (cdr b) e e w s mod))
- ((memv key '(global)) (values type n e e w s mod))
- ((memv key '(macro))
- (if for-car?
- (values type (cdr b) e e w s mod)
- (syntax-type
- (expand-macro (cdr b) e r w s rib mod)
- r
- '(())
- s
- rib
- mod
- #f)))
- (else (values type (cdr b) e e w s mod)))))
+ (call-with-values
+ (lambda () (resolve-identifier e w r mod #t))
+ (lambda (type value mod*)
+ (let ((key type))
+ (cond ((memv key '(macro))
+ (if for-car?
+ (values type value e e w s mod)
+ (syntax-type
+ (expand-macro value e r w s rib mod)
+ r
+ '(())
+ s
+ rib
+ mod
+ #f)))
+ ((memv key '(global)) (values type value e value w s mod*))
+ (else (values type value e e w s mod)))))))
((pair? e)
(let ((first (car e)))
(call-with-values
@@ -822,7 +841,7 @@
(lambda () (value e r w))
(lambda (e r w s mod) (expand e r w mod))))
((memv key '(lexical-call))
- (expand-application
+ (expand-call
(let ((id (car e)))
(build-lexical-reference
'fun
@@ -835,7 +854,7 @@
s
mod))
((memv key '(global-call))
- (expand-application
+ (expand-call
(build-global-reference
(source-annotation (car e))
(if (syntax-object? value) (syntax-object-expression value) value)
@@ -849,7 +868,7 @@
(build-data s (strip (source-wrap e w s mod) '(()))))
((memv key '(global)) (build-global-reference s value mod))
((memv key '(call))
- (expand-application (expand (car e) r w mod) e r w s mod))
+ (expand-call (expand (car e) r w mod) e r w s mod))
((memv key '(begin-form))
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
(if tmp-1
@@ -858,15 +877,10 @@
(let ((tmp-1 ($sc-dispatch tmp '(_))))
(if tmp-1
(apply (lambda ()
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions are deprecated. Use *unspecified*.")
- (expand-void))
- (syntax-violation
- #f
- "sequence of zero expressions"
- (source-wrap e w s mod))))
+ (syntax-violation
+ #f
+ "sequence of zero expressions"
+ (source-wrap e w s mod)))
tmp-1)
(syntax-violation
#f
@@ -905,12 +919,12 @@
(source-wrap e w s mod)))
(else
(syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))))
- (expand-application
+ (expand-call
(lambda (x e r w s mod)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any))))
(if tmp
(apply (lambda (e0 e1)
- (build-application s x (map (lambda (e) (expand e r w mod)) e1)))
+ (build-call s x (map (lambda (e) (expand e r w mod)) e1)))
tmp)
(syntax-violation
#f
@@ -990,7 +1004,7 @@
(cons var vars)
(cons (cons er (wrap e w mod)) vals)
(cons (cons 'lexical var) bindings)))))
- ((memv key '(define-syntax-form define-syntax-parameter-form))
+ ((memv key '(define-syntax-form))
(let ((id (wrap value w mod))
(label (gen-label))
(trans-r (macros-only-env er)))
@@ -1002,6 +1016,19 @@
(list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod)))
(cdr r)))
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
+ ((memv key '(define-syntax-parameter-form))
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
+ (extend-ribcage! ribcage id label)
+ (set-cdr!
+ r
+ (extend-env
+ (list label)
+ (list (cons 'syntax-parameter
+ (list (eval-local-transformer (expand e trans-r w mod) mod))))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
((memv key '(begin-form))
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
(if tmp
@@ -1516,28 +1543,34 @@
(tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
(if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
(apply (lambda (var val e1 e2)
- (let ((names (map (lambda (x) (id-var-name x w)) var)))
- (for-each
- (lambda (id n)
- (let ((key (car (lookup n r mod))))
- (if (memv key '(displaced-lexical))
- (syntax-violation
- 'syntax-parameterize
- "identifier out of context"
- e
- (source-wrap id w s mod)))))
- var
- names)
+ (let ((names (map (lambda (x)
+ (call-with-values
+ (lambda () (resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(displaced-lexical))
+ (syntax-violation
+ 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap x w s mod)))
+ ((memv key '(syntax-parameter)) value)
+ (else
+ (syntax-violation
+ 'syntax-parameterize
+ "invalid syntax parameter"
+ e
+ (source-wrap x w s mod))))))))
+ var))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
+ val))))
(expand-body
(cons e1 e2)
(source-wrap e w s mod)
- (extend-env
- names
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
- val))
- r)
+ (extend-env names bindings r)
w
mod)))
tmp)
@@ -1560,15 +1593,16 @@
((gen-syntax
(lambda (src e r maps ellipsis? mod)
(if (id? e)
- (let* ((label (id-var-name e '(()))) (b (lookup label r mod)))
- (cond ((eq? (car b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (cdr b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values (list 'ref var) maps))))
- ((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src))
- (else (values (list 'quote e) maps))))
+ (call-with-values
+ (lambda () (resolve-identifier e '(()) r mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(syntax))
+ (call-with-values
+ (lambda () (gen-ref src (car value) (cdr value) maps))
+ (lambda (var maps) (values (list 'ref var) maps))))
+ ((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src))
+ (else (values (list 'quote e) maps))))))
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
(if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1))
(apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #f) mod))
@@ -1678,8 +1712,7 @@
(if (list? (cadr x))
(build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x)))
- (else
- (build-application #f (build-primref #f (car x)) (map regen (cdr x)))))))))
+ (else (build-primcall #f (car x) (map regen (cdr x)))))))))
(lambda (e r w s mod)
(let* ((e (source-wrap e w s mod))
(tmp e)
@@ -1870,36 +1903,36 @@
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
(if (and tmp (apply (lambda (id val) (id? id)) tmp))
(apply (lambda (id val)
- (let ((n (id-var-name id w))
- (id-mod (if (syntax-object? id) (syntax-object-module id) mod)))
- (let* ((b (lookup n r id-mod)) (key (car b)))
- (cond ((memv key '(lexical))
- (build-lexical-assignment
- s
- (syntax->datum id)
- (cdr b)
- (expand val r w mod)))
- ((memv key '(global))
- (build-global-assignment s n (expand val r w mod) id-mod))
- ((memv key '(macro))
- (let ((p (cdr b)))
- (if (procedure-property p 'variable-transformer)
- (expand (expand-macro p e r w s #f mod) r '(()) mod)
+ (call-with-values
+ (lambda () (resolve-identifier id w r mod #t))
+ (lambda (type value id-mod)
+ (let ((key type))
+ (cond ((memv key '(lexical))
+ (build-lexical-assignment
+ s
+ (syntax->datum id)
+ value
+ (expand val r w mod)))
+ ((memv key '(global))
+ (build-global-assignment s value (expand val r w mod) id-mod))
+ ((memv key '(macro))
+ (if (procedure-property value 'variable-transformer)
+ (expand (expand-macro value e r w s #f mod) r '(()) mod)
(syntax-violation
'set!
"not a variable transformer"
(wrap e w mod)
- (wrap id w id-mod)))))
- ((memv key '(displaced-lexical))
- (syntax-violation 'set! "identifier out of context" (wrap id w mod)))
- (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
+ (wrap id w id-mod))))
+ ((memv key '(displaced-lexical))
+ (syntax-violation 'set! "identifier out of context" (wrap id w mod)))
+ (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
tmp)
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
(if tmp
(apply (lambda (head tail val)
(call-with-values
(lambda () (syntax-type head r '(()) #f #f mod #t))
- (lambda (type value formform ee ww ss modmod)
+ (lambda (type value ee* ee ww ss modmod)
(let ((key type))
(if (memv key '(module-ref))
(let ((val (expand val r w mod)))
@@ -1914,7 +1947,7 @@
#f
"source expression failed to match any pattern"
tmp-1))))))
- (build-application
+ (build-call
s
(expand
(list '#(syntax-object setter ((top)) (hygiene guile)) head)
@@ -2115,9 +2148,9 @@
(lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
- (build-application
+ (build-primcall
#f
- (build-primref #f 'apply)
+ 'apply
(list (build-simple-lambda
#f
(map syntax->datum ids)
@@ -2146,7 +2179,7 @@
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
(else
(let ((y (gen-var 'tmp)))
- (build-application
+ (build-call
#f
(build-simple-lambda
#f
@@ -2168,17 +2201,14 @@
(build-dispatch-call pvars exp y r mod)
(gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any)
- (build-application #f (build-primref #f 'list) (list x))
- (build-application
- #f
- (build-primref #f '$sc-dispatch)
- (list x (build-data #f p)))))))))))))
+ (build-primcall #f 'list (list x))
+ (build-primcall #f '$sc-dispatch (list x (build-data #f p)))))))))))))
(gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
- (build-application
+ (build-primcall
#f
- (build-primref #f 'syntax-violation)
+ 'syntax-violation
(list (build-data #f #f)
(build-data #f "source expression failed to match any pattern")
x))
@@ -2192,7 +2222,7 @@
(if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
(expand exp r '(()) mod)
(let ((labels (list (gen-label))) (var (gen-var pat)))
- (build-application
+ (build-call
#f
(build-simple-lambda
#f
@@ -2222,7 +2252,7 @@
(apply (lambda (val key m)
(if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) key)
(let ((x (gen-var 'tmp)))
- (build-application
+ (build-call
s
(build-simple-lambda
#f
@@ -2309,7 +2339,9 @@
(syntax-violation 'syntax-module "invalid argument" x)))
(cdr (syntax-object-module id))))
(syntax-local-binding
- (lambda (id)
+ (lambda* (id
+ #:key
+ (resolve-syntax-parameters? #t #:resolve-syntax-parameters?))
(let ((x id))
(if (not (nonsymbol-id? x))
(syntax-violation 'syntax-local-binding "invalid argument" x)))
@@ -2328,11 +2360,14 @@
(syntax-object-expression id)
(strip-anti-mark (syntax-object-wrap id))
r
- (syntax-object-module id)))
+ (syntax-object-module id)
+ resolve-syntax-parameters?))
(lambda (type value mod)
(let ((key type))
(cond ((memv key '(lexical)) (values 'lexical value))
((memv key '(macro)) (values 'macro value))
+ ((memv key '(syntax-parameter))
+ (values 'syntax-parameter (car value)))
((memv key '(syntax)) (values 'pattern-variable value))
((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
((memv key '(global)) (values 'global (cons value (cdr mod))))
@@ -2531,13 +2566,22 @@
(vector
'(#(syntax-object macro-type ((top)) (hygiene guile))
.
- #(syntax-object syntax-rules ((top)) (hygiene guile)))
+ #(syntax-object
+ syntax-rules
+ ((top)
+ #(ribcage
+ #(syntax-rules)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object syntax-rules ((top)) (hygiene guile))))))
+ (hygiene guile)))
(cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
(cons '#(syntax-object syntax-case ((top)) (hygiene guile))
(cons '#(syntax-object x ((top)) (hygiene guile))
(cons k
(map (lambda (tmp-1 tmp)
- (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp)
+ (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
(list '#(syntax-object syntax ((top)) (hygiene guile))
tmp-1)))
template
@@ -2556,13 +2600,22 @@
(vector
'(#(syntax-object macro-type ((top)) (hygiene guile))
.
- #(syntax-object syntax-rules ((top)) (hygiene guile)))
+ #(syntax-object
+ syntax-rules
+ ((top)
+ #(ribcage
+ #(syntax-rules)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object syntax-rules ((top)) (hygiene guile))))))
+ (hygiene guile)))
(cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
(cons '#(syntax-object syntax-case ((top)) (hygiene guile))
(cons '#(syntax-object x ((top)) (hygiene guile))
(cons k
(map (lambda (tmp-1 tmp)
- (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp)
+ (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
(list '#(syntax-object syntax ((top)) (hygiene guile))
tmp-1)))
template
@@ -2662,11 +2715,32 @@
tmp-1)
(let ((tmp-1 ($sc-dispatch
tmp
- '(#(free-id #(syntax-object quasiquote ((top)) (hygiene guile))) any))))
+ '(#(free-id
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage
+ #(quasiquote)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object quasiquote ((top)) (hygiene guile))))))
+ (hygiene guile)))
+ any))))
(if tmp-1
(apply (lambda (p)
(quasicons
- '("quote" #(syntax-object quasiquote ((top)) (hygiene guile)))
+ '("quote"
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage
+ #(quasiquote)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object quasiquote ((top)) (hygiene guile))))))
+ (hygiene guile)))
(quasi (list p) (+ lev 1))))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any . any))))
@@ -3050,7 +3124,16 @@
'(#(syntax-object x ((top)) (hygiene guile)))
'#((#(syntax-object macro-type ((top)) (hygiene guile))
.
- #(syntax-object identifier-syntax ((top)) (hygiene guile))))
+ #(syntax-object
+ identifier-syntax
+ ((top)
+ #(ribcage
+ #(identifier-syntax)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object identifier-syntax ((top)) (hygiene guile))))))
+ (hygiene guile))))
(list '#(syntax-object syntax-case ((top)) (hygiene guile))
'#(syntax-object x ((top)) (hygiene guile))
'()
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 228d8e32a..1aa54020f 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -316,9 +316,9 @@
(lambda (source)
(make-void source)))
- (define build-application
+ (define build-call
(lambda (source fun-exp arg-exps)
- (make-application source fun-exp arg-exps)))
+ (make-call source fun-exp arg-exps)))
(define build-conditional
(lambda (source test-exp then-exp else-exp)
@@ -405,12 +405,14 @@
(lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case)))
+ (define build-primcall
+ (lambda (src name args)
+ (make-primcall src name args)))
+
(define build-primref
(lambda (src name)
- (if (equal? (module-name (current-module)) '(guile))
- (make-toplevel-ref src name)
- (make-module-ref src '(guile) name #f))))
-
+ (make-primitive-ref src name)))
+
(define (build-data src exp)
(make-const src exp))
@@ -418,7 +420,7 @@
(lambda (src exps)
(if (null? (cdr exps))
(car exps)
- (make-sequence src exps))))
+ (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(define build-let
(lambda (src ids vars val-exps body-exp)
@@ -439,8 +441,8 @@
(make-letrec
src #f
(list f-name) (list f) (list proc)
- (build-application src (build-lexical-reference 'fun src f-name f)
- val-exps))))))
+ (build-call src (build-lexical-reference 'fun src f-name f)
+ val-exps))))))
(define build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
@@ -485,13 +487,14 @@
;; global (assumed global variable) and displaced-lexical (see below)
;; do not show up in any environment; instead, they are fabricated by
- ;; lookup when it finds no other bindings.
+ ;; resolve-identifier when it finds no other bindings.
;; <environment> ::= ((<label> . <binding>)*)
;; identifier bindings include a type and a value
;; <binding> ::= (macro . <procedure>) macros
+ ;; (syntax-parameter . (<procedure>)) syntax parameters
;; (core . <procedure>) core forms
;; (module-ref . <procedure>) @ or @@
;; (begin) begin
@@ -563,22 +566,10 @@
(if (null? r)
'()
(let ((a (car r)))
- (if (eq? (cadr a) 'macro)
+ (if (memq (cadr a) '(macro syntax-parameter))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
- (define lookup
- ;; x may be a label or a symbol
- ;; although symbols are usually global, we check the environment first
- ;; anyway because a temporary binding may have been established by
- ;; fluid-let-syntax
- (lambda (x r mod)
- (cond
- ((assq x r) => cdr)
- ((symbol? x)
- (or (get-global-definition-hook x mod) (make-binding 'global)))
- (else (make-binding 'displaced-lexical)))))
-
(define global-extend
(lambda (type sym val)
(put-global-definition-hook sym type val)))
@@ -731,51 +722,86 @@
(same-marks? (cdr x) (cdr y))))))
(define id-var-name
- (lambda (id w)
+ ;; Syntax objects use wraps to associate names with marked
+ ;; identifiers. This function returns the name corresponding to
+ ;; the given identifier and wrap, or the original identifier if no
+ ;; corresponding name was found.
+ ;;
+ ;; The name may be a string created by gen-label, indicating a
+ ;; lexical binding, or another syntax object, indicating a
+ ;; reference to a top-level definition created during a previous
+ ;; macroexpansion.
+ ;;
+ ;; For lexical variables, finding a label simply amounts to
+ ;; looking for an entry with the same symbolic name and the same
+ ;; marks. Finding a toplevel definition is the same, except we
+ ;; also have to compare modules, hence the `mod' parameter.
+ ;; Instead of adding a separate entry in the ribcage for modules,
+ ;; which wouldn't be used for lexicals, we arrange for the entry
+ ;; for the name entry to be a pair with the module in its car, and
+ ;; the name itself in the cdr. So if the name that we find is a
+ ;; pair, we have to check modules.
+ ;;
+ ;; The identifer may be passed in wrapped or unwrapped. In any
+ ;; case, this routine returns either a symbol, a syntax object, or
+ ;; a string label.
+ ;;
+ (lambda (id w mod)
(define-syntax-rule (first e)
;; Rely on Guile's multiple-values truncation.
e)
(define search
- (lambda (sym subst marks)
+ (lambda (sym subst marks mod)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
+ (search sym (cdr subst) (cdr marks) mod)
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
+ (search-vector-rib sym subst marks symnames fst mod)
+ (search-list-rib sym subst marks symnames fst mod))))))))
(define search-list-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0))
(cond
- ((null? symnames) (search sym (cdr subst) marks))
+ ((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (list-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (cdr symnames) (fx+ i 1)))
+ (values n marks))))
(else (f (cdr symnames) (fx+ i 1)))))))
(define search-vector-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames)))
(let f ((i 0))
(cond
- ((fx= i n) (search sym (cdr subst) marks))
+ ((fx= i n) (search sym (cdr subst) marks mod))
((and (eq? (vector-ref symnames i) sym)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (vector-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (fx+ i 1)))
+ (values n marks))))
(else (f (fx+ i 1))))))))
(cond
((symbol? id)
- (or (first (search id (wrap-subst w) (wrap-marks w))) id))
+ (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
((syntax-object? id)
(let ((id (syntax-object-expression id))
- (w1 (syntax-object-wrap id)))
+ (w1 (syntax-object-wrap id))
+ (mod (syntax-object-module id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
- (call-with-values (lambda () (search id (wrap-subst w) marks))
+ (call-with-values (lambda () (search id (wrap-subst w) marks mod))
(lambda (new-id marks)
(or new-id
- (first (search id (wrap-subst w1) marks))
+ (first (search id (wrap-subst w1) marks mod))
id))))))
(else (syntax-violation 'id-var-name "invalid id" id)))))
@@ -830,19 +856,31 @@
;; Returns three values: binding type, binding value, the module (for
;; resolving toplevel vars).
- (define (resolve-identifier id w r mod)
+ (define (resolve-identifier id w r mod resolve-syntax-parameters?)
+ (define (resolve-syntax-parameters b)
+ (if (and resolve-syntax-parameters?
+ (eq? (binding-type b) 'syntax-parameter))
+ (or (assq-ref r (binding-value b))
+ (make-binding 'macro (car (binding-value b))))
+ b))
(define (resolve-global var mod)
- (let ((b (or (get-global-definition-hook var mod)
- (make-binding 'global))))
+ (let ((b (resolve-syntax-parameters
+ (or (get-global-definition-hook var mod)
+ (make-binding 'global)))))
(if (eq? (binding-type b) 'global)
(values 'global var mod)
(values (binding-type b) (binding-value b) mod))))
(define (resolve-lexical label mod)
- (let ((b (or (assq-ref r label)
- (make-binding 'displaced-lexical))))
+ (let ((b (resolve-syntax-parameters
+ (or (assq-ref r label)
+ (make-binding 'displaced-lexical)))))
(values (binding-type b) (binding-value b) mod)))
- (let ((n (id-var-name id w)))
+ (let ((n (id-var-name id w mod)))
(cond
+ ((syntax-object? n)
+ ;; Recursing allows syntax-parameterize to override
+ ;; macro-introduced syntax parameters.
+ (resolve-identifier n w r mod resolve-syntax-parameters?))
((symbol? n)
(resolve-global n (if (syntax-object? id)
(syntax-object-module id)
@@ -867,9 +905,39 @@
(define free-id=?
(lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
+ (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
+ (mj (and (syntax-object? j) (syntax-object-module j)))
+ (ni (id-var-name i empty-wrap mi))
+ (nj (id-var-name j empty-wrap mj)))
+ (define (id-module-binding id mod)
+ (module-variable
+ (if mod
+ ;; The normal case.
+ (resolve-module (cdr mod))
+ ;; Either modules have not been booted, or we have a
+ ;; raw symbol coming in, which is possible.
+ (current-module))
+ (id-sym-name id)))
+ (cond
+ ((syntax-object? ni) (free-id=? ni j))
+ ((syntax-object? nj) (free-id=? i nj))
+ ((symbol? ni)
+ ;; `i' is not lexically bound. Assert that `j' is free,
+ ;; and if so, compare their bindings, that they are either
+ ;; bound to the same variable, or both unbound and have
+ ;; the same name.
+ (and (eq? nj (id-sym-name j))
+ (let ((bi (id-module-binding i mi)))
+ (if bi
+ (eq? bi (id-module-binding j mj))
+ (and (not (id-module-binding j mj))
+ (eq? ni nj))))
+ (eq? (id-module-binding i mi) (id-module-binding j mj))))
+ (else
+ ;; Otherwise `i' is bound, so check that `j' is bound, and
+ ;; bound to the same thing.
+ (equal? ni nj))))))
+
;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;; long as the missing portion of the wrap is common to both of the ids
;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
@@ -960,161 +1028,171 @@
;;
(define expand-top-sequence
(lambda (body r w s m esew mod)
- (define (scan body r w s m esew mod exps)
- (cond
- ((null? body)
- ;; in reversed order
- exps)
- (else
+ (let* ((r (cons '("placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+ (define (record-definition! id var)
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ ;; Ribcages map symbol+marks to names, mostly for
+ ;; resolving lexicals. Here to add a mapping for toplevel
+ ;; definitions we also need to match the module. So, we
+ ;; put it in the name instead, and make id-var-name handle
+ ;; the special case of names that are pairs. See the
+ ;; comments in id-var-name for more.
+ (extend-ribcage! ribcage id
+ (cons (syntax-object-module id)
+ (wrap var top-wrap mod)))))
+ (define (macro-introduced-identifier? id)
+ (not (equal? (wrap-marks (syntax-object-wrap id)) '(top))))
+ (define (fresh-derived-name id orig-form)
+ (symbol-append
+ (syntax-object-expression id)
+ '-
+ (string->symbol
+ ;; FIXME: `hash' currently stops descending into nested
+ ;; data at some point, so it's less unique than we would
+ ;; like. Also this encodes hash values into the ABI of
+ ;; compiled modules; a problem?
+ (number->string
+ (hash (syntax->datum orig-form) most-positive-fixnum)
+ 16))))
+ (define (parse body r w s m esew mod)
+ (let lp ((body body) (exps '()))
+ (if (null? body)
+ exps
+ (lp (cdr body)
+ (append (parse1 (car body) r w s m esew mod)
+ exps)))))
+ (define (parse1 x r w s m esew mod)
(call-with-values
(lambda ()
- (call-with-values
- (lambda ()
- (let ((e (car body)))
- (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
- (lambda (type value form e w s mod)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) exps)
- ((_ e1 e2 ...)
- (scan #'(e1 e2 ...) r w s m esew mod exps))))
- ((local-syntax-form)
- (expand-local-syntax value e r w s mod
- (lambda (body r w s mod)
- (scan body r w s m esew mod exps))))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (parse-when-list e #'(x ...)))
- (body #'(e1 e2 ...)))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (scan body r w s
- (if (memq 'expand when-list) 'c&e 'e)
- '(eval)
- mod exps)
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod))
- (values exps))))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (scan body r w s 'c&e '(compile load) mod exps)
- (if (memq m '(c c&e))
- (scan body r w s 'c '(load) mod exps)
- (values exps))))
- ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod)
- (values exps))
- (else
- (values exps)))))))
- ((define-syntax-form define-syntax-parameter-form)
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (case m
- ((c)
- (if (memq 'compile esew)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew)
- (values (cons e exps))
- (values exps)))
- (if (memq 'load esew)
- (values (cons (expand-install-global n (expand e r w mod))
- exps))
- (values exps))))
- ((c&e)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (values (cons e exps))))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (expand-install-global n (expand e r w mod))
- mod))
- (values exps)))))
- ((define-form)
- (let* ((n (id-var-name value w))
- ;; Lookup the name in the module of the define form.
- (type (binding-type (lookup n r mod))))
- (case type
- ((global core macro module-ref)
- ;; affect compile-time environment (once we have booted)
- (if (and (memq m '(c c&e))
- (not (module-local-variable (current-module) n))
- (current-module))
- (let ((old (module-variable (current-module) n)))
- ;; use value of the same-named imported variable, if
- ;; any
- (if (and (variable? old) (variable-bound? old))
- (module-define! (current-module) n (variable-ref old))
- (module-add! (current-module) n (make-undefined-variable)))))
- (values
- (cons
- (if (eq? m 'c&e)
- (let ((x (build-global-definition s n (expand e r w mod))))
- (top-level-eval-hook x mod)
- x)
- (lambda ()
- (build-global-definition s n (expand e r w mod))))
- exps)))
- ((displaced-lexical)
- (syntax-violation #f "identifier out of context"
- (source-wrap form w s mod)
- (wrap value w mod)))
- (else
- (syntax-violation #f "cannot define keyword at top level"
- (source-wrap form w s mod)
- (wrap value w mod))))))
- (else
- (values (cons
- (if (eq? m 'c&e)
- (let ((x (expand-expr type value form e r w s mod)))
- (top-level-eval-hook x mod)
- x)
- (lambda ()
- (expand-expr type value form e r w s mod)))
- exps)))))))
- (lambda (exps)
- (scan (cdr body) r w s m esew mod exps))))))
-
- (call-with-values (lambda ()
- (scan body r w s m esew mod '()))
- (lambda (exps)
+ (syntax-type x r w (source-annotation x) ribcage mod #f))
+ (lambda (type value form e w s mod)
+ (case type
+ ((define-form)
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (list
+ (if (eq? m 'c&e)
+ (let ((x (build-global-definition s var (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda ()
+ (build-global-definition s var (expand e r w mod)))))))
+ ((define-syntax-form define-syntax-parameter-form)
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (case m
+ ((c)
+ (cond
+ ((memq 'compile esew)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew)
+ (list (lambda () e))
+ '())))
+ ((memq 'load esew)
+ (list (lambda ()
+ (expand-install-global var type (expand e r w mod)))))
+ (else '())))
+ ((c&e)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (list (lambda () e))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global var type (expand e r w mod))
+ mod))
+ '()))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse #'(e1 ...) r w s m esew mod))))
+ ((local-syntax-form)
+ (expand-local-syntax value e r w s mod
+ (lambda (forms r w s mod)
+ (parse forms r w s m esew mod))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (parse-when-list e #'(x ...)))
+ (body #'(e1 e2 ...)))
+ (define (recurse m esew)
+ (parse body r w s m esew mod))
+ (cond
+ ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (recurse (if (memq 'expand when-list) 'c&e 'e)
+ '(eval))
+ (begin
+ (if (memq 'expand when-list)
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod))
+ '())))
+ ((memq 'load when-list)
+ (if (or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (recurse 'c&e '(compile load))
+ (if (memq m '(c c&e))
+ (recurse 'c '(load))
+ '())))
+ ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ '())
+ (else
+ '()))))))
+ (else
+ (list
+ (if (eq? m 'c&e)
+ (let ((x (expand-expr type value form e r w s mod)))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda ()
+ (expand-expr type value form e r w s mod)))))))))
+ (let ((exps (map (lambda (x) (x))
+ (reverse (parse body r w s m esew mod)))))
(if (null? exps)
(build-void s)
- (build-sequence
- s
- (let lp ((in exps) (out '()))
- (if (null? in) out
- (let ((e (car in)))
- (lp (cdr in)
- (cons (if (procedure? e) (e) e) out)))))))))))
+ (build-sequence s exps))))))
(define expand-install-global
- (lambda (name e)
+ (lambda (name type e)
(build-global-definition
no-source
name
- (build-application
+ (build-primcall
no-source
- (build-primref no-source 'make-syntax-transformer)
- (list (build-data no-source name)
- (build-data no-source 'macro)
- e)))))
-
+ 'make-syntax-transformer
+ (if (eq? type 'define-syntax-parameter-form)
+ (list (build-data no-source name)
+ (build-data no-source 'syntax-parameter)
+ (build-primcall no-source 'list (list e)))
+ (list (build-data no-source name)
+ (build-data no-source 'macro)
+ e))))))
+
(define parse-when-list
(lambda (e when-list)
- ;; when-list is syntax'd version of list of situations
+ ;; `when-list' is syntax'd version of list of situations. We
+ ;; could match these keywords lexically, via free-id=?, but then
+ ;; we twingle the definition of eval-when to the bindings of
+ ;; eval, load, expand, and compile, which is totally unintended.
+ ;; So do a symbolic match instead.
(let ((result (strip when-list empty-wrap)))
(let lp ((l result))
(if (null? l)
@@ -1168,18 +1246,19 @@
(lambda (e r w s rib mod for-car?)
(cond
((symbol? e)
- (let* ((n (id-var-name e w))
- (b (lookup n r mod))
- (type (binding-type b)))
- (case type
- ((lexical) (values type (binding-value b) e e w s mod))
- ((global) (values type n e e w s mod))
- ((macro)
- (if for-car?
- (values type (binding-value b) e e w s mod)
- (syntax-type (expand-macro (binding-value b) e r w s rib mod)
- r empty-wrap s rib mod #f)))
- (else (values type (binding-value b) e e w s mod)))))
+ (call-with-values (lambda () (resolve-identifier e w r mod #t))
+ (lambda (type value mod*)
+ (case type
+ ((macro)
+ (if for-car?
+ (values type value e e w s mod)
+ (syntax-type (expand-macro value e r w s rib mod)
+ r empty-wrap s rib mod #f)))
+ ((global)
+ ;; Toplevel definitions may resolve to bindings with
+ ;; different names or in different modules.
+ (values type value e value w s mod*))
+ (else (values type value e e w s mod))))))
((pair? e)
(let ((first (car e)))
(call-with-values
@@ -1271,7 +1350,7 @@
(lambda (e r w s mod)
(expand e r w mod))))
((lexical-call)
- (expand-application
+ (expand-call
(let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id)
(if (syntax-object? id)
@@ -1280,7 +1359,7 @@
value))
e r w s mod))
((global-call)
- (expand-application
+ (expand-call
(build-global-reference (source-annotation (car e))
(if (syntax-object? value)
(syntax-object-expression value)
@@ -1291,18 +1370,13 @@
e r w s mod))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod))
- ((call) (expand-application (expand (car e) r w mod) e r w s mod))
+ ((call) (expand-call (expand (car e) r w mod) e r w s mod))
((begin-form)
(syntax-case e ()
((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))
((_)
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions are deprecated. Use *unspecified*.")
- (expand-void))
- (syntax-violation #f "sequence of zero expressions"
- (source-wrap e w s mod))))))
+ (syntax-violation #f "sequence of zero expressions"
+ (source-wrap e w s mod)))))
((local-syntax-form)
(expand-local-syntax value e r w s mod expand-sequence))
((eval-when-form)
@@ -1324,12 +1398,12 @@
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
- (define expand-application
+ (define expand-call
(lambda (x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
- (build-application s x
- (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
+ (build-call s x
+ (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy)
;;
@@ -1354,7 +1428,7 @@
;;
;; The only wrinkle is when we want a macro to expand to code in another
;; module, as is the case for the r6rs `library' form -- the body expressions
- ;; should be scoped relative the new module, the one defined by the macro.
+ ;; should be scoped relative the the new module, the one defined by the macro.
;; For that, use `(@@ mod-name body)'.
;;
;; Part of the macro output will be from the site of the macro use and part
@@ -1469,7 +1543,7 @@
(cons id var-ids)
(cons var vars) (cons (cons er (wrap e w mod)) vals)
(cons (make-binding 'lexical var) bindings)))))
- ((define-syntax-form define-syntax-parameter-form)
+ ((define-syntax-form)
(let ((id (wrap value w mod))
(label (gen-label))
(trans-r (macros-only-env er)))
@@ -1479,12 +1553,29 @@
;; compile-time environment immediately, so that the newly-defined
;; keywords may be used in definition context within the same
;; lexical contour.
- (set-cdr! r (extend-env (list label)
- (list (make-binding 'macro
- (eval-local-transformer
- (expand e trans-r w mod)
- mod)))
- (cdr r)))
+ (set-cdr! r (extend-env
+ (list label)
+ (list (make-binding
+ 'macro
+ (eval-local-transformer
+ (expand e trans-r w mod)
+ mod)))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
+ ((define-syntax-parameter-form)
+ ;; Same as define-syntax-form, but different format of the binding.
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
+ (extend-ribcage! ribcage id label)
+ (set-cdr! r (extend-env
+ (list label)
+ (list (make-binding
+ 'syntax-parameter
+ (list (eval-local-transformer
+ (expand e trans-r w mod)
+ mod))))
+ (cdr r)))
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
((begin-form)
(syntax-case e ()
@@ -1840,38 +1931,45 @@
(global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f)
- (global-extend 'core 'syntax-parameterize
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((var val) ...) e1 e2 ...)
- (valid-bound-ids? #'(var ...))
- (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
- (for-each
- (lambda (id n)
- (case (binding-type (lookup n r mod))
- ((displaced-lexical)
- (syntax-violation 'syntax-parameterize
- "identifier out of context"
- e
- (source-wrap id w s mod)))))
- #'(var ...)
- names)
- (expand-body
- #'(e1 e2 ...)
- (source-wrap e w s mod)
- (extend-env
- names
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (make-binding 'macro
- (eval-local-transformer (expand x trans-r w mod)
- mod)))
- #'(val ...)))
- r)
- w
- mod)))
- (_ (syntax-violation 'syntax-parameterize "bad syntax"
- (source-wrap e w s mod))))))
+ (global-extend
+ 'core 'syntax-parameterize
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? #'(var ...))
+ (let ((names
+ (map (lambda (x)
+ (call-with-values
+ (lambda () (resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((displaced-lexical)
+ (syntax-violation 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap x w s mod)))
+ ((syntax-parameter)
+ value)
+ (else
+ (syntax-violation 'syntax-parameterize
+ "invalid syntax parameter"
+ e
+ (source-wrap x w s mod)))))))
+ #'(var ...)))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding
+ 'macro
+ (eval-local-transformer (expand x trans-r w mod) mod)))
+ #'(val ...)))))
+ (expand-body #'(e1 e2 ...)
+ (source-wrap e w s mod)
+ (extend-env names bindings r)
+ w
+ mod)))
+ (_ (syntax-violation 'syntax-parameterize "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'quote
(lambda (e r w s mod)
@@ -1880,167 +1978,166 @@
(_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod))))))
- (global-extend 'core 'syntax
- (let ()
- (define gen-syntax
- (lambda (src e r maps ellipsis? mod)
- (if (id? e)
- (let ((label (id-var-name e empty-wrap)))
- ;; Mod does not matter, we are looking to see if
- ;; the id is lexical syntax.
- (let ((b (lookup label r mod)))
- (if (eq? (binding-type b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (binding-value b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values `(ref ,var) maps)))
- (if (ellipsis? e)
- (syntax-violation 'syntax "misplaced ellipsis" src)
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? #'dots)
- (gen-syntax src #'e r maps (lambda (x) #f) mod))
- ((x dots . y)
- ;; this could be about a dozen lines of code, except that we
- ;; choose to handle #'(x ... ...) forms
- (ellipsis? #'dots)
- (let f ((y #'y)
- (k (lambda (maps)
- (call-with-values
- (lambda ()
- (gen-syntax src #'x r
- (cons '() maps) ellipsis? mod))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis"
- src)
- (values (gen-map x (car maps))
- (cdr maps))))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? #'dots)
- (f #'y
- (lambda (maps)
- (call-with-values
- (lambda () (k (cons '() maps)))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis" src)
- (values (gen-mappend x (car maps))
- (cdr maps))))))))
- (_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis? mod))
- (lambda (y maps)
- (call-with-values
- (lambda () (k maps))
- (lambda (x maps)
- (values (gen-append x y) maps)))))))))
- ((x . y)
- (call-with-values
- (lambda () (gen-syntax src #'x r maps ellipsis? mod))
- (lambda (x maps)
- (call-with-values
- (lambda () (gen-syntax src #'y r maps ellipsis? mod))
- (lambda (y maps) (values (gen-cons x y) maps))))))
- (#(e1 e2 ...)
- (call-with-values
- (lambda ()
- (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
- (lambda (e maps) (values (gen-vector e) maps))))
- (_ (values `(quote ,e) maps))))))
-
- (define gen-ref
- (lambda (src var level maps)
- (if (fx= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-violation 'syntax "missing ellipsis" src)
- (call-with-values
- (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
- (lambda (outer-var outer-maps)
- (let ((b (assq outer-var (car maps))))
- (if b
- (values (cdr b) maps)
- (let ((inner-var (gen-var 'tmp)))
- (values inner-var
- (cons (cons (cons outer-var inner-var)
- (car maps))
- outer-maps)))))))))))
-
- (define gen-mappend
- (lambda (e map-env)
- `(apply (primitive append) ,(gen-map e map-env))))
-
- (define gen-map
- (lambda (e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ;; identity map equivalence:
- ;; (map (lambda (x) x) y) == y
- (car actuals))
- ((and-map
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ;; eta map equivalence:
- ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals))))))
-
- (define gen-cons
- (lambda (x y)
- (case (car y)
- ((quote)
- (if (eq? (car x) 'quote)
- `(quote (,(cadr x) . ,(cadr y)))
- (if (eq? (cadr y) '())
- `(list ,x)
- `(cons ,x ,y))))
- ((list) `(list ,x ,@(cdr y)))
- (else `(cons ,x ,y)))))
-
- (define gen-append
- (lambda (x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y))))
-
- (define gen-vector
- (lambda (x)
- (cond
- ((eq? (car x) 'list) `(vector ,@(cdr x)))
- ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
- (else `(list->vector ,x)))))
-
-
- (define regen
- (lambda (x)
- (case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda)
- (if (list? (cadr x))
- (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
- (error "how did we get here" x)))
- (else (build-application no-source
- (build-primref no-source (car x))
- (map regen (cdr x)))))))
-
- (lambda (e r w s mod)
- (let ((e (source-wrap e w s mod)))
- (syntax-case e ()
- ((_ x)
+ (global-extend
+ 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis? mod)
+ (if (id? e)
+ (call-with-values (lambda ()
+ (resolve-identifier e empty-wrap r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((syntax)
+ (call-with-values
+ (lambda () (gen-ref src (car value) (cdr value) maps))
+ (lambda (var maps)
+ (values `(ref ,var) maps))))
+ (else
+ (if (ellipsis? e)
+ (syntax-violation 'syntax "misplaced ellipsis" src)
+ (values `(quote ,e) maps))))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? #'dots)
+ (gen-syntax src #'e r maps (lambda (x) #f) mod))
+ ((x dots . y)
+ ;; this could be about a dozen lines of code, except that we
+ ;; choose to handle #'(x ... ...) forms
+ (ellipsis? #'dots)
+ (let f ((y #'y)
+ (k (lambda (maps)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'x r
+ (cons '() maps) ellipsis? mod))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis"
+ src)
+ (values (gen-map x (car maps))
+ (cdr maps))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? #'dots)
+ (f #'y
+ (lambda (maps)
(call-with-values
- (lambda () (gen-syntax e #'x r '() ellipsis? mod))
- (lambda (e maps) (regen e))))
- (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
+ (lambda () (k (cons '() maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis" src)
+ (values (gen-mappend x (car maps))
+ (cdr maps))))))))
+ (_ (call-with-values
+ (lambda () (gen-syntax src y r maps ellipsis? mod))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps)
+ (values (gen-append x y) maps)))))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (gen-syntax src #'x r maps ellipsis? mod))
+ (lambda (x maps)
+ (call-with-values
+ (lambda () (gen-syntax src #'y r maps ellipsis? mod))
+ (lambda (y maps) (values (gen-cons x y) maps))))))
+ (#(e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
+ (lambda (e maps) (values (gen-vector e) maps))))
+ (_ (values `(quote ,e) maps))))))
+
+ (define gen-ref
+ (lambda (src var level maps)
+ (if (fx= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-violation 'syntax "missing ellipsis" src)
+ (call-with-values
+ (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values inner-var
+ (cons (cons (cons outer-var inner-var)
+ (car maps))
+ outer-maps)))))))))))
+
+ (define gen-mappend
+ (lambda (e map-env)
+ `(apply (primitive append) ,(gen-map e map-env))))
+
+ (define gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ;; identity map equivalence:
+ ;; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((and-map
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ ;; eta map equivalence:
+ ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+ (define gen-cons
+ (lambda (x y)
+ (case (car y)
+ ((quote)
+ (if (eq? (car x) 'quote)
+ `(quote (,(cadr x) . ,(cadr y)))
+ (if (eq? (cadr y) '())
+ `(list ,x)
+ `(cons ,x ,y))))
+ ((list) `(list ,x ,@(cdr y)))
+ (else `(cons ,x ,y)))))
+
+ (define gen-append
+ (lambda (x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y))))
+
+ (define gen-vector
+ (lambda (x)
+ (cond
+ ((eq? (car x) 'list) `(vector ,@(cdr x)))
+ ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+ (else `(list->vector ,x)))))
+
+
+ (define regen
+ (lambda (x)
+ (case (car x)
+ ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda)
+ (if (list? (cadr x))
+ (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
+ (error "how did we get here" x)))
+ (else (build-primcall no-source (car x) (map regen (cdr x)))))))
+
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
+ (syntax-case e ()
+ ((_ x)
+ (call-with-values
+ (lambda () (gen-syntax e #'x r '() ellipsis? mod))
+ (lambda (e maps) (regen e))))
+ (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
(global-extend 'core 'lambda
(lambda (e r w s mod)
@@ -2175,58 +2272,53 @@
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
- (global-extend 'core 'set!
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ id val)
- (id? #'id)
- (let ((n (id-var-name #'id w))
- ;; Lookup id in its module
- (id-mod (if (syntax-object? #'id)
- (syntax-object-module #'id)
- mod)))
- (let ((b (lookup n r id-mod)))
- (case (binding-type b)
- ((lexical)
- (build-lexical-assignment s
- (syntax->datum #'id)
- (binding-value b)
- (expand #'val r w mod)))
- ((global)
- (build-global-assignment s n (expand #'val r w mod) id-mod))
- ((macro)
- (let ((p (binding-value b)))
- (if (procedure-property p 'variable-transformer)
- ;; As syntax-type does, call expand-macro with
- ;; the mod of the expression. Hmm.
- (expand (expand-macro p e r w s #f mod) r empty-wrap mod)
- (syntax-violation 'set! "not a variable transformer"
- (wrap e w mod)
- (wrap #'id w id-mod)))))
- ((displaced-lexical)
- (syntax-violation 'set! "identifier out of context"
- (wrap #'id w mod)))
- (else (syntax-violation 'set! "bad set!"
- (source-wrap e w s mod)))))))
- ((_ (head tail ...) val)
- (call-with-values
- (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
- (lambda (type value formform ee ww ss modmod)
- (case type
- ((module-ref)
- (let ((val (expand #'val r w mod)))
- (call-with-values (lambda () (value #'(head tail ...) r w))
- (lambda (e r w s* mod)
- (syntax-case e ()
- (e (id? #'e)
- (build-global-assignment s (syntax->datum #'e)
- val mod)))))))
- (else
- (build-application s
- (expand #'(setter head) r w mod)
- (map (lambda (e) (expand e r w mod))
- #'(tail ... val))))))))
- (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+ (global-extend
+ 'core 'set!
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ id val)
+ (id? #'id)
+ (call-with-values
+ (lambda () (resolve-identifier #'id w r mod #t))
+ (lambda (type value id-mod)
+ (case type
+ ((lexical)
+ (build-lexical-assignment s (syntax->datum #'id) value
+ (expand #'val r w mod)))
+ ((global)
+ (build-global-assignment s value (expand #'val r w mod) id-mod))
+ ((macro)
+ (if (procedure-property value 'variable-transformer)
+ ;; As syntax-type does, call expand-macro with
+ ;; the mod of the expression. Hmm.
+ (expand (expand-macro value e r w s #f mod) r empty-wrap mod)
+ (syntax-violation 'set! "not a variable transformer"
+ (wrap e w mod)
+ (wrap #'id w id-mod))))
+ ((displaced-lexical)
+ (syntax-violation 'set! "identifier out of context"
+ (wrap #'id w mod)))
+ (else
+ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
+ ((_ (head tail ...) val)
+ (call-with-values
+ (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
+ (lambda (type value ee* ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (expand #'val r w mod)))
+ (call-with-values (lambda () (value #'(head tail ...) r w))
+ (lambda (e r w s* mod)
+ (syntax-case e ()
+ (e (id? #'e)
+ (build-global-assignment s (syntax->datum #'e)
+ val mod)))))))
+ (else
+ (build-call s
+ (expand #'(setter head) r w mod)
+ (map (lambda (e) (expand e r w mod))
+ #'(tail ... val))))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@
(lambda (e r w)
@@ -2388,20 +2480,21 @@
(lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
- (build-application no-source
- (build-primref no-source 'apply)
- (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
- (expand exp
- (extend-env
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)
- mod))
- y))))))
+ (build-primcall
+ no-source
+ 'apply
+ (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
+ (expand exp
+ (extend-env
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)
+ mod))
+ y))))))
(define gen-clause
(lambda (x keys clauses r pat fender exp mod)
@@ -2416,36 +2509,32 @@
(else
(let ((y (gen-var 'tmp)))
;; fat finger binding and references to temp variable y
- (build-application no-source
- (build-simple-lambda no-source (list 'tmp) #f (list y) '()
- (let ((y (build-lexical-reference 'value no-source
- 'tmp y)))
- (build-conditional no-source
- (syntax-case fender ()
- (#t y)
- (_ (build-conditional no-source
- y
- (build-dispatch-call pvars fender y r mod)
- (build-data no-source #f))))
- (build-dispatch-call pvars exp y r mod)
- (gen-syntax-case x keys clauses r mod))))
- (list (if (eq? p 'any)
- (build-application no-source
- (build-primref no-source 'list)
- (list x))
- (build-application no-source
- (build-primref no-source '$sc-dispatch)
- (list x (build-data no-source p)))))))))))))
+ (build-call no-source
+ (build-simple-lambda no-source (list 'tmp) #f (list y) '()
+ (let ((y (build-lexical-reference 'value no-source
+ 'tmp y)))
+ (build-conditional no-source
+ (syntax-case fender ()
+ (#t y)
+ (_ (build-conditional no-source
+ y
+ (build-dispatch-call pvars fender y r mod)
+ (build-data no-source #f))))
+ (build-dispatch-call pvars exp y r mod)
+ (gen-syntax-case x keys clauses r mod))))
+ (list (if (eq? p 'any)
+ (build-primcall no-source 'list (list x))
+ (build-primcall no-source '$sc-dispatch
+ (list x (build-data no-source p)))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
- (build-application no-source
- (build-primref no-source 'syntax-violation)
- (list (build-data no-source #f)
- (build-data no-source
- "source expression failed to match any pattern")
- x))
+ (build-primcall no-source 'syntax-violation
+ (list (build-data no-source #f)
+ (build-data no-source
+ "source expression failed to match any pattern")
+ x))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? #'pat)
@@ -2455,18 +2544,18 @@
(expand #'exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var #'pat)))
- (build-application no-source
- (build-simple-lambda
- no-source (list (syntax->datum #'pat)) #f (list var)
- '()
- (expand #'exp
- (extend-env labels
- (list (make-binding 'syntax `(,var . 0)))
- r)
- (make-binding-wrap #'(pat)
- labels empty-wrap)
- mod))
- (list x))))
+ (build-call no-source
+ (build-simple-lambda
+ no-source (list (syntax->datum #'pat)) #f (list var)
+ '()
+ (expand #'exp
+ (extend-env labels
+ (list (make-binding 'syntax `(,var . 0)))
+ r)
+ (make-binding-wrap #'(pat)
+ labels empty-wrap)
+ mod))
+ (list x))))
(gen-clause x keys (cdr clauses) r
#'pat #t #'exp mod)))
((pat fender exp)
@@ -2483,14 +2572,14 @@
#'(key ...))
(let ((x (gen-var 'tmp)))
;; fat finger binding and references to temp variable x
- (build-application s
- (build-simple-lambda no-source (list 'tmp) #f (list x) '()
- (gen-syntax-case (build-lexical-reference 'value no-source
- 'tmp x)
- #'(key ...) #'(m ...)
- r
- mod))
- (list (expand #'val r empty-wrap mod))))
+ (build-call s
+ (build-simple-lambda no-source (list 'tmp) #f (list x) '()
+ (gen-syntax-case (build-lexical-reference 'value no-source
+ 'tmp x)
+ #'(key ...) #'(m ...)
+ r
+ mod))
+ (list (expand #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e))))))))
;; The portable macroexpand seeds expand-top's mode m with 'e (for
@@ -2559,7 +2648,7 @@
(arg-check nonsymbol-id? id 'syntax-module)
(cdr (syntax-object-module id)))
- (define (syntax-local-binding id)
+ (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
(arg-check nonsymbol-id? id 'syntax-local-binding)
(with-transformer-environment
(lambda (e r w s rib mod)
@@ -2575,11 +2664,13 @@
(syntax-object-expression id)
(strip-anti-mark (syntax-object-wrap id))
r
- (syntax-object-module id)))
+ (syntax-object-module id)
+ resolve-syntax-parameters?))
(lambda (type value mod)
(case type
((lexical) (values 'lexical value))
((macro) (values 'macro value))
+ ((syntax-parameter) (values 'syntax-parameter (car value)))
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
((global) (values 'global (cons value (cdr mod))))
@@ -2783,7 +2874,7 @@
#((macro-type . syntax-rules)
(patterns pattern ...))
(syntax-case x (k ...)
- ((dummy . pattern) #'template)
+ ((_ . pattern) #'template)
...)))
((_ (k ...) docstring ((keyword . pattern) template) ...)
(string? (syntax->datum #'docstring))
@@ -2793,7 +2884,7 @@
#((macro-type . syntax-rules)
(patterns pattern ...))
(syntax-case x (k ...)
- ((dummy . pattern) #'template)
+ ((_ . pattern) #'template)
...))))))
(define-syntax define-syntax-rule
diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm
deleted file mode 100644
index bedfbdea7..000000000
--- a/module/ice-9/r4rs.scm
+++ /dev/null
@@ -1,243 +0,0 @@
-;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
-;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
-
-;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010, 2011, 2012 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-(eval-when (compile)
- (set-current-module (resolve-module '(guile))))
-
-
-;;;; apply and call-with-current-continuation
-
-;;; The deal with these is that they are the procedural wrappers around the
-;;; primitives of Guile's language. There are about 20 different kinds of
-;;; expression in Guile, and e.g. @apply is one of them. (It has to be that way
-;;; to preserve tail recursion.)
-;;;
-;;; Usually we recognize (apply foo bar) to be an instance of @apply, but in the
-;;; case that apply is passed to apply, or we're bootstrapping, we need a
-;;; trampoline -- and here they are.
-(define (apply fun . args)
- (@apply fun (apply:nconc2last args)))
-(define (call-with-current-continuation proc)
- (@call-with-current-continuation proc))
-(define (call-with-values producer consumer)
- (@call-with-values producer consumer))
-(define (dynamic-wind in thunk out)
- "All three arguments must be 0-argument procedures.
-Guard @var{in} is called, then @var{thunk}, then
-guard @var{out}.
-
-If, any time during the execution of @var{thunk}, the
-continuation of the @code{dynamic_wind} expression is escaped
-non-locally, @var{out} is called. If the continuation of
-the dynamic-wind is re-entered, @var{in} is called. Thus
-@var{in} and @var{out} may be called any number of
-times.
-@lisp
- (define x 'normal-binding)
-@result{} x
- (define a-cont
- (call-with-current-continuation
- (lambda (escape)
- (let ((old-x x))
- (dynamic-wind
- ;; in-guard:
- ;;
- (lambda () (set! x 'special-binding))
-
- ;; thunk
- ;;
- (lambda () (display x) (newline)
- (call-with-current-continuation escape)
- (display x) (newline)
- x)
-
- ;; out-guard:
- ;;
- (lambda () (set! x old-x)))))))
-
-;; Prints:
-special-binding
-;; Evaluates to:
-@result{} a-cont
-x
-@result{} normal-binding
- (a-cont #f)
-;; Prints:
-special-binding
-;; Evaluates to:
-@result{} a-cont ;; the value of the (define a-cont...)
-x
-@result{} normal-binding
-a-cont
-@result{} special-binding
-@end lisp"
- (@dynamic-wind in (thunk) out))
-
-
-;;;; Basic Port Code
-
-;;; Specifically, the parts of the low-level port code that are written in
-;;; Scheme rather than C.
-;;;
-;;; WARNING: the parts of this interface that refer to file ports
-;;; are going away. It would be gone already except that it is used
-;;; "internally" in a few places.
-
-
-;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the
-;;; proper mode to open files in.
-;;;
-;;; If we want to support systems that do CRLF->LF translation, like
-;;; Windows, then we should have a symbol in scmconfig.h made visible
-;;; to the Scheme level that we can test here, and autoconf magic to
-;;; #define it when appropriate. Windows will probably just have a
-;;; hand-generated scmconfig.h file.
-(define OPEN_READ "r")
-(define OPEN_WRITE "w")
-(define OPEN_BOTH "r+")
-
-(define *null-device* "/dev/null")
-
-(define (open-input-file str)
- "Takes a string naming an existing file and returns an input port
-capable of delivering characters from the file. If the file
-cannot be opened, an error is signalled."
- (open-file str OPEN_READ))
-
-(define (open-output-file str)
- "Takes a string naming an output file to be created and returns an
-output port capable of writing characters to a new file by that
-name. If the file cannot be opened, an error is signalled. If a
-file with the given name already exists, the effect is unspecified."
- (open-file str OPEN_WRITE))
-
-(define (open-io-file str)
- "Open file with name STR for both input and output."
- (open-file str OPEN_BOTH))
-
-(define (call-with-input-file str proc)
- "PROC should be a procedure of one argument, and STR should be a
-string naming a file. The file must
-already exist. These procedures call PROC
-with one argument: the port obtained by opening the named file for
-input or output. If the file cannot be opened, an error is
-signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.
-If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will
-never again be used for a read or write operation."
- (let ((p (open-input-file str)))
- (call-with-values
- (lambda () (proc p))
- (lambda vals
- (close-input-port p)
- (apply values vals)))))
-
-(define (call-with-output-file str proc)
- "PROC should be a procedure of one argument, and STR should be a
-string naming a file. The behaviour is unspecified if the file
-already exists. These procedures call PROC
-with one argument: the port obtained by opening the named file for
-input or output. If the file cannot be opened, an error is
-signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.
-If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will
-never again be used for a read or write operation."
- (let ((p (open-output-file str)))
- (call-with-values
- (lambda () (proc p))
- (lambda vals
- (close-output-port p)
- (apply values vals)))))
-
-(define (with-input-from-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-output-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-error-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-input-from-file file thunk)
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The file must already exist. The file is opened for
-input, an input port connected to it is made
-the default value returned by `current-input-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-input-file file
- (lambda (p) (with-input-from-port p thunk))))
-
-(define (with-output-to-file file thunk)
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
-The file is opened for output, an output port connected to it is made
-the default value returned by `current-output-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-output-file file
- (lambda (p) (with-output-to-port p thunk))))
-
-(define (with-error-to-file file thunk)
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
-The file is opened for output, an output port connected to it is made
-the default value returned by `current-error-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-output-file file
- (lambda (p) (with-error-to-port p thunk))))
-
-(define (with-input-from-string string thunk)
- "THUNK must be a procedure of no arguments.
-The test of STRING is opened for
-input, an input port connected to it is made,
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed.
-Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-input-string string
- (lambda (p) (with-input-from-port p thunk))))
-
-(define (with-output-to-string thunk)
- "Calls THUNK and returns its output as a string."
- (call-with-output-string
- (lambda (p) (with-output-to-port p thunk))))
-
-(define (with-error-to-string thunk)
- "Calls THUNK and returns its error output as a string."
- (call-with-output-string
- (lambda (p) (with-error-to-port p thunk))))
-
-(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
diff --git a/module/ice-9/weak-vector.scm b/module/ice-9/weak-vector.scm
index 09e2e0a8d..31d79ec6f 100644
--- a/module/ice-9/weak-vector.scm
+++ b/module/ice-9/weak-vector.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,13 +19,8 @@
(define-module (ice-9 weak-vector)
- :export (make-weak-vector list->weak-vector weak-vector weak-vector?
- make-weak-key-alist-vector
- make-weak-value-alist-vector
- make-doubly-weak-alist-vector
- weak-key-alist-vector?
- weak-value-alist-vector?
- doubly-weak-alist-vector?) ; C
- )
+ #:export (make-weak-vector list->weak-vector weak-vector weak-vector?))
-(%init-weaks-builtins) ; defined in libguile/weaks.c
+(eval-when (load eval compile)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_weak_vector_builtins"))
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 181fb06ab..d54186e16 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -133,6 +133,8 @@
((br-if-not-eq ,l) (write-break l))
((br-if-null ,l) (write-break l))
((br-if-not-null ,l) (write-break l))
+ ((br-if-nil ,l) (write-break l))
+ ((br-if-not-nil ,l) (write-break l))
((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index 5d30be391..dcdd78073 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -125,7 +125,9 @@
(case inst
((list vector)
(list "~a element~:p" (apply make-int16 args)))
- ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
+ ((br
+ br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null
+ br-if-nil br-if-not-nil)
(list "-> ~A" (assq-ref labels (car args))))
((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
(list "-> ~A" (assq-ref labels (caddr args))))
diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm
index 33d563490..f9dd036e8 100644
--- a/module/language/brainfuck/compile-tree-il.scm
+++ b/module/language/brainfuck/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Brainfuck for GNU Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -94,7 +94,7 @@
(parse-tree-il
`(let (pointer tape) (pointer tape)
((const 0)
- (apply (primitive make-vector) (const ,tape-size) (const 0)))
+ (call (primitive make-vector) (const ,tape-size) (const 0)))
,(compile-body exp)))
env
env))
@@ -109,11 +109,11 @@
(cond
((null? in)
;; No more input, build our output.
- (cond
- ((null? out) '(void)) ; no output
- ((null? (cdr out)) (car out)) ; single expression
- (else `(begin ,@(reverse out)))) ; sequence
- )
+ (cond
+ ((null? out) '(void)) ; no output
+ ((null? (cdr out)) (car out)) ; single expression
+ (else `(begin ,@(reverse out)))) ; sequence
+ )
(else
(pmatch (car in)
@@ -121,34 +121,34 @@
;; (set! pointer (+ pointer +-1))
((<bf-move> ,dir)
(emit `(set! (lexical pointer)
- (apply (primitive +) (lexical pointer) (const ,dir)))))
+ (call (primitive +) (lexical pointer) (const ,dir)))))
;; Cell increment +- is done as:
;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
((<bf-increment> ,inc)
- (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
- (apply (primitive +)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const ,inc)))))
+ (emit `(call (primitive vector-set!) (lexical tape) (lexical pointer)
+ (call (primitive +)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const ,inc)))))
;; Output . is done by converting the cell's integer value to a
;; character first and then printing out this character:
;; (write-char (integer->char (vector-ref tape pointer)))
((<bf-print>)
- (emit `(apply (primitive write-char)
- (apply (primitive integer->char)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))))))
+ (emit `(call (primitive write-char)
+ (call (primitive integer->char)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))))))
;; Input , is done similarly, read in a character, get its ASCII
;; code and store it into the current cell:
;; (vector-set! tape pointer (char->integer (read-char)))
((<bf-read>)
- (emit `(apply (primitive vector-set!)
- (lexical tape) (lexical pointer)
- (apply (primitive char->integer)
- (apply (primitive read-char))))))
+ (emit `(call (primitive vector-set!)
+ (lexical tape) (lexical pointer)
+ (call (primitive char->integer)
+ (call (primitive read-char))))))
;; For loops [...] we use a letrec construction to execute the body until
;; the current cell gets zero. The body is compiled via a recursive call
@@ -171,14 +171,14 @@
((lambda ()
(lambda-case
((() #f #f #f () ())
- (if (apply (primitive =)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const 0))
+ (if (call (primitive =)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const 0))
(void)
(begin ,(compile-body body)
- (apply (lexical ,iterate)))))
+ (call (lexical ,iterate)))))
#f)))
- (apply (lexical ,iterate))))))
+ (call (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in))))))))
diff --git a/module/language/bytecode/spec.scm b/module/language/bytecode/spec.scm
index 1d7e79b57..ca703c33c 100644
--- a/module/language/bytecode/spec.scm
+++ b/module/language/bytecode/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,14 +20,15 @@
(define-module (language bytecode spec)
#:use-module (system base language)
+ #:use-module (system base target)
#:use-module (system vm objcode)
#:export (bytecode))
(define (compile-objcode x e opts)
- (values (bytecode->objcode x) e e))
+ (values (bytecode->objcode x (target-endianness)) e e))
(define (decompile-objcode x e opts)
- (values (objcode->bytecode x) e))
+ (values (objcode->bytecode x (target-endianness)) e))
(define-language bytecode
#:title "Guile Bytecode Vectors"
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
index b5f0a3528..2fe0d924e 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -32,7 +32,7 @@
(-> (@ '(language ecmascript impl) 'sym)))
(define-syntax-rule (@impl sym arg ...)
- (-> (apply (@implv sym) arg ...)))
+ (-> (call (@implv sym) arg ...)))
(define (empty-lexical-environment)
'())
@@ -82,7 +82,7 @@
(parameterize ((current-return-tag
(-> (lexical 'return tag))))
(-> (let '(return) (list tag)
- (list (-> (apply (-> (primitive 'make-prompt-tag)))))
+ (list (-> (primcall 'make-prompt-tag)))
(-> (prompt (current-return-tag)
(body-thunk)
(let ((val (gensym "val")))
@@ -115,23 +115,23 @@
(this
(@impl get-this))
((+ ,a)
- (-> (apply (-> (primitive '+))
- (@impl ->number (comp a e))
- (-> (const 0)))))
+ (-> (call (-> (primitive '+))
+ (@impl ->number (comp a e))
+ (-> (const 0)))))
((- ,a)
- (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+ (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
((~ ,a)
(@impl bitwise-not (comp a e)))
((! ,a)
(@impl logical-not (comp a e)))
((+ ,a ,b)
- (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
((- ,a ,b)
- (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
((/ ,a ,b)
- (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
((* ,a ,b)
- (-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
((% ,a ,b)
(@impl mod (comp a e) (comp b e)))
((<< ,a ,b)
@@ -139,27 +139,27 @@
((>> ,a ,b)
(@impl shift (comp a e) (comp `(- ,b) e)))
((< ,a ,b)
- (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
((<= ,a ,b)
- (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
((> ,a ,b)
- (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
((>= ,a ,b)
- (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
((in ,a ,b)
(@impl has-property? (comp a e) (comp b e)))
((== ,a ,b)
- (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
((!= ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'equal?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'equal?))
+ (comp a e) (comp b e))))))
((=== ,a ,b)
- (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
((!== ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'eqv?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'eqv?))
+ (comp a e) (comp b e))))))
((& ,a ,b)
(@impl band (comp a e) (comp b e)))
((^ ,a ,b)
@@ -188,9 +188,9 @@
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set! (lookup foo e)
- (-> (apply (-> (primitive '+))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -201,9 +201,9 @@
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -216,16 +216,16 @@
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
((postdec (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set (lookup foo e)
- (-> (apply (-> (primitive '-))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postdec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -236,9 +236,9 @@
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '-))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postdec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -258,18 +258,18 @@
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '+))
- v
- (-> (const 1))))))
+ (-> (call (-> (primitive '+))
+ v
+ (-> (const 1))))))
v))))
((preinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput (-> (lexical objvar objvar))
(-> (const prop))
@@ -279,11 +279,11 @@
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
@@ -293,18 +293,18 @@
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '-))
+ (-> (call (-> (primitive '-))
v
(-> (const 1))))))
v))))
((predec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
@@ -315,11 +315,11 @@
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
@@ -359,7 +359,7 @@
(-> (lambda '()
`(lambda-case
((() #f #f #f () ())
- (apply ,(@impl pget obj prop) ,@args)))))))
+ (call ,(@impl pget obj prop) ,@args)))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
@@ -371,24 +371,24 @@
,@(map (lambda (x) (comp x e)) args))
e))
((call ,proc ,args)
- `(apply ,(comp proc e)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(comp proc e)
+ ,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
(return (comp expr e)))
((array . ,args)
- `(apply ,(@implv new-array)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(@implv new-array)
+ ,@(map (lambda (x) (comp x e)) args)))
((object . ,args)
- `(apply ,(@implv new-object)
- ,@(map (lambda (x)
- (pmatch x
- ((,prop ,val)
- (-> (apply (-> (primitive 'cons))
- (-> (const prop))
- (comp val e))))
- (else
- (error "bad prop-val pair" x))))
- args)))
+ `(call ,(@implv new-object)
+ ,@(map (lambda (x)
+ (pmatch x
+ ((,prop ,val)
+ (-> (call (-> (primitive 'cons))
+ (-> (const prop))
+ (comp val e))))
+ (else
+ (error "bad prop-val pair" x))))
+ args)))
((pref ,obj ,prop)
(@impl pget
(comp obj e)
@@ -463,14 +463,14 @@
`((() #f #f #f () ())
,(-> (begin
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
(-> (lambda '()
(-> (lambda-case
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
- (-> (apply (-> (lexical '%loop %loop))))
+ (-> (call (-> (lexical '%loop %loop))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%loop %loop)))))))))
+ (-> (call (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
@@ -480,9 +480,9 @@
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
(-> (begin (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
@@ -496,10 +496,10 @@
(comp 'true e))
(-> (begin (comp statement e)
(comp (or inc '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
((for-in ,var ,object ,statement)
(let ((%enum (gensym "%enum "))
@@ -519,9 +519,9 @@
,(-> (const 'pop))))
e)
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((block ,x)
(comp x e))
diff --git a/module/language/elisp/bindings.scm b/module/language/elisp/bindings.scm
index 6ff56fdcd..9fabddfc4 100644
--- a/module/language/elisp/bindings.scm
+++ b/module/language/elisp/bindings.scm
@@ -19,21 +19,22 @@
;;; Code:
(define-module (language elisp bindings)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
#:export (make-bindings
- mark-global-needed!
- map-globals-needed
with-lexical-bindings
with-dynamic-bindings
- get-lexical-binding))
+ with-function-bindings
+ get-lexical-binding
+ get-function-binding))
;;; This module defines routines to handle analysis of symbol bindings
;;; used during elisp compilation. This data allows to collect the
;;; symbols, for which globals need to be created, or mark certain
;;; symbols as lexically bound.
;;;
-;;; Needed globals are stored in an association-list that stores a list
-;;; of symbols for each module they are needed in.
-;;;
;;; The lexical bindings of symbols are stored in a hash-table that
;;; associates symbols to fluids; those fluids are used in the
;;; with-lexical-binding and with-dynamic-binding routines to associate
@@ -41,64 +42,32 @@
;;; Record type used to hold the data necessary.
-(define bindings-type
- (make-record-type 'bindings '(needed-globals lexical-bindings)))
+(define-record-type bindings
+ (%make-bindings lexical-bindings function-bindings)
+ bindings?
+ (lexical-bindings lexical-bindings)
+ (function-bindings function-bindings))
;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation.
(define (make-bindings)
- ((record-constructor bindings-type) '() (make-hash-table)))
-
-;;; Mark that a given symbol is needed as global in the specified
-;;; slot-module.
-
-(define (mark-global-needed! bindings sym module)
- (let* ((old-needed ((record-accessor bindings-type 'needed-globals)
- bindings))
- (old-in-module (or (assoc-ref old-needed module) '()))
- (new-in-module (if (memq sym old-in-module)
- old-in-module
- (cons sym old-in-module)))
- (new-needed (assoc-set! old-needed module new-in-module)))
- ((record-modifier bindings-type 'needed-globals)
- bindings
- new-needed)))
-
-;;; Cycle through all globals needed in order to generate the code for
-;;; their creation or some other analysis.
-
-(define (map-globals-needed bindings proc)
- (let ((needed ((record-accessor bindings-type 'needed-globals)
- bindings)))
- (let iterate-modules ((mod-tail needed)
- (mod-result '()))
- (if (null? mod-tail)
- mod-result
- (iterate-modules
- (cdr mod-tail)
- (let* ((aentry (car mod-tail))
- (module (car aentry))
- (symbols (cdr aentry)))
- (let iterate-symbols ((sym-tail symbols)
- (sym-result mod-result))
- (if (null? sym-tail)
- sym-result
- (iterate-symbols (cdr sym-tail)
- (cons (proc module (car sym-tail))
- sym-result))))))))))
+ (%make-bindings (make-hash-table) (make-hash-table)))
;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound.
(define (get-lexical-binding bindings sym)
- (let* ((lex ((record-accessor bindings-type 'lexical-bindings)
- bindings))
+ (let* ((lex (lexical-bindings bindings))
(slot (hash-ref lex sym #f)))
(if slot
(fluid-ref slot)
#f)))
+(define (get-function-binding bindings symbol)
+ (and=> (hash-ref (function-bindings bindings) symbol)
+ fluid-ref))
+
;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.
@@ -106,8 +75,7 @@
(if (or (not (list? syms))
(not (and-map symbol? syms)))
(error "can't bind non-symbols" syms))
- (let ((lex ((record-accessor bindings-type 'lexical-bindings)
- bindings)))
+ (let ((lex (lexical-bindings bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
(hash-set! lex sym (make-fluid))))
@@ -127,3 +95,13 @@
syms
(map (lambda (el) #f) syms)
proc))
+
+(define (with-function-bindings bindings symbols gensyms thunk)
+ (let ((fb (function-bindings bindings)))
+ (for-each (lambda (symbol)
+ (if (not (hash-ref fb symbol))
+ (hash-set! fb symbol (make-fluid))))
+ symbols)
+ (with-fluids* (map (cut hash-ref fb <>) symbols)
+ gensyms
+ thunk)))
diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el
new file mode 100644
index 000000000..f55722a9a
--- /dev/null
+++ b/module/language/elisp/boot.el
@@ -0,0 +1,617 @@
+;;; Guile Emacs Lisp -*- lexical-binding: t -*-
+
+;;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;;; This library is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;;; 02110-1301 USA
+
+;;; Code:
+
+(defmacro @ (module symbol)
+ `(guile-ref ,module ,symbol))
+
+(defmacro eval-and-compile (&rest body)
+ `(progn
+ (eval-when-compile ,@body)
+ (progn ,@body)))
+
+(eval-and-compile
+ (defun null (object)
+ (if object nil t))
+ (defun consp (object)
+ (%funcall (@ (guile) pair?) object))
+ (defun listp (object)
+ (if object (consp object) t))
+ (defun car (list)
+ (if list (%funcall (@ (guile) car) list) nil))
+ (defun cdr (list)
+ (if list (%funcall (@ (guile) cdr) list) nil))
+ (defun make-symbol (name)
+ (%funcall (@ (guile) make-symbol) name))
+ (defun signal (error-symbol data)
+ (%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
+
+(defmacro lambda (&rest cdr)
+ `#'(lambda ,@cdr))
+
+(defmacro prog1 (first &rest body)
+ (let ((temp (make-symbol "prog1-temp")))
+ `(let ((,temp ,first))
+ (declare (lexical ,temp))
+ ,@body
+ ,temp)))
+
+(defmacro prog2 (form1 form2 &rest body)
+ `(progn ,form1 (prog1 ,form2 ,@body)))
+
+(defmacro cond (&rest clauses)
+ (if (null clauses)
+ nil
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (listp first)
+ (let ((condition (car first))
+ (body (cdr first)))
+ (if (null body)
+ (let ((temp (make-symbol "cond-temp")))
+ `(let ((,temp ,condition))
+ (declare (lexical ,temp))
+ (if ,temp
+ ,temp
+ (cond ,@rest))))
+ `(if ,condition
+ (progn ,@body)
+ (cond ,@rest))))
+ (signal 'wrong-type-argument `(listp ,first))))))
+
+(defmacro and (&rest conditions)
+ (cond ((null conditions) t)
+ ((null (cdr conditions)) (car conditions))
+ (t `(if ,(car conditions)
+ (and ,@(cdr conditions))
+ nil))))
+
+(defmacro or (&rest conditions)
+ (cond ((null conditions) nil)
+ ((null (cdr conditions)) (car conditions))
+ (t (let ((temp (make-symbol "or-temp")))
+ `(let ((,temp ,(car conditions)))
+ (declare (lexical ,temp))
+ (if ,temp
+ ,temp
+ (or ,@(cdr conditions))))))))
+
+(defmacro lexical-let (bindings &rest body)
+ (labels ((loop (list vars)
+ (if (null list)
+ `(let ,bindings
+ (declare (lexical ,@vars))
+ ,@body)
+ (loop (cdr list)
+ (if (consp (car list))
+ `(,(car (car list)) ,@vars)
+ `(,(car list) ,@vars))))))
+ (loop bindings '())))
+
+(defmacro lexical-let* (bindings &rest body)
+ (labels ((loop (list vars)
+ (if (null list)
+ `(let* ,bindings
+ (declare (lexical ,@vars))
+ ,@body)
+ (loop (cdr list)
+ (if (consp (car list))
+ (cons (car (car list)) vars)
+ (cons (car list) vars))))))
+ (loop bindings '())))
+
+(defmacro while (test &rest body)
+ (let ((loop (make-symbol "loop")))
+ `(labels ((,loop ()
+ (if ,test
+ (progn ,@body (,loop))
+ nil)))
+ (,loop))))
+
+(defmacro unwind-protect (bodyform &rest unwindforms)
+ `(funcall (@ (guile) dynamic-wind)
+ #'(lambda () nil)
+ #'(lambda () ,bodyform)
+ #'(lambda () ,@unwindforms)))
+
+(defmacro when (cond &rest body)
+ `(if ,cond
+ (progn ,@body)))
+
+(defmacro unless (cond &rest body)
+ `(when (not ,cond)
+ ,@body))
+
+(defun symbolp (object)
+ (%funcall (@ (guile) symbol?) object))
+
+(defun functionp (object)
+ (%funcall (@ (guile) procedure?) object))
+
+(defun symbol-function (symbol)
+ (let ((f (%funcall (@ (language elisp runtime) symbol-function)
+ symbol)))
+ (if (%funcall (@ (language elisp falias) falias?) f)
+ (%funcall (@ (language elisp falias) falias-object) f)
+ f)))
+
+(defun eval (form)
+ (%funcall (@ (system base compile) compile)
+ form
+ (%funcall (@ (guile) symbol->keyword) 'from)
+ 'elisp
+ (%funcall (@ (guile) symbol->keyword) 'to)
+ 'value))
+
+(defun %indirect-function (object)
+ (cond
+ ((functionp object)
+ object)
+ ((symbolp object) ;++ cycle detection
+ (%indirect-function (symbol-function object)))
+ ((listp object)
+ (eval `(function ,object)))
+ (t
+ (signal 'invalid-function `(,object)))))
+
+(defun apply (function &rest arguments)
+ (%funcall (@ (guile) apply)
+ (@ (guile) apply)
+ (%indirect-function function)
+ arguments))
+
+(defun funcall (function &rest arguments)
+ (%funcall (@ (guile) apply)
+ (%indirect-function function)
+ arguments))
+
+(defun fset (symbol definition)
+ (funcall (@ (language elisp runtime) set-symbol-function!)
+ symbol
+ (if (functionp definition)
+ definition
+ (funcall (@ (language elisp falias) make-falias)
+ #'(lambda (&rest args) (apply definition args))
+ definition)))
+ definition)
+
+(defun load (file)
+ (funcall (@ (system base compile) compile-file)
+ file
+ (funcall (@ (guile) symbol->keyword) 'from)
+ 'elisp
+ (funcall (@ (guile) symbol->keyword) 'to)
+ 'value)
+ t)
+
+;;; Equality predicates
+
+(defun eq (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) eq?) obj1 obj2)
+ (null obj2)))
+
+(defun eql (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) eqv?) obj1 obj2)
+ (null obj2)))
+
+(defun equal (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) equal?) obj1 obj2)
+ (null obj2)))
+
+;;; Symbols
+
+;;; `symbolp' and `symbol-function' are defined above.
+
+(fset 'symbol-name (@ (guile) symbol->string))
+(fset 'symbol-value (@ (language elisp runtime) symbol-value))
+(fset 'set (@ (language elisp runtime) set-symbol-value!))
+(fset 'makunbound (@ (language elisp runtime) makunbound!))
+(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
+(fset 'boundp (@ (language elisp runtime) symbol-bound?))
+(fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
+(fset 'intern (@ (guile) string->symbol))
+
+(defun defvaralias (new-alias base-variable &optional docstring)
+ (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
+ base-variable)))
+ (funcall (@ (language elisp runtime) set-symbol-fluid!)
+ new-alias
+ fluid)
+ base-variable))
+
+;;; Numerical type predicates
+
+(defun floatp (object)
+ (and (funcall (@ (guile) real?) object)
+ (or (funcall (@ (guile) inexact?) object)
+ (null (funcall (@ (guile) integer?) object)))))
+
+(defun integerp (object)
+ (and (funcall (@ (guile) integer?) object)
+ (funcall (@ (guile) exact?) object)))
+
+(defun numberp (object)
+ (funcall (@ (guile) real?) object))
+
+(defun wholenump (object)
+ (and (integerp object) (>= object 0)))
+
+(defun zerop (object)
+ (= object 0))
+
+;;; Numerical comparisons
+
+(fset '= (@ (guile) =))
+
+(defun /= (num1 num2)
+ (null (= num1 num2)))
+
+(fset '< (@ (guile) <))
+(fset '<= (@ (guile) <=))
+(fset '> (@ (guile) >))
+(fset '>= (@ (guile) >=))
+
+(defun max (&rest numbers)
+ (apply (@ (guile) max) numbers))
+
+(defun min (&rest numbers)
+ (apply (@ (guile) min) numbers))
+
+;;; Arithmetic functions
+
+(fset '1+ (@ (guile) 1+))
+(fset '1- (@ (guile) 1-))
+(fset '+ (@ (guile) +))
+(fset '- (@ (guile) -))
+(fset '* (@ (guile) *))
+(fset '% (@ (guile) modulo))
+(fset 'abs (@ (guile) abs))
+
+;;; Floating-point rounding
+
+(fset 'ffloor (@ (guile) floor))
+(fset 'fceiling (@ (guile) ceiling))
+(fset 'ftruncate (@ (guile) truncate))
+(fset 'fround (@ (guile) round))
+
+;;; Numeric conversion
+
+(defun float (arg)
+ (if (numberp arg)
+ (funcall (@ (guile) exact->inexact) arg)
+ (signal 'wrong-type-argument `(numberp ,arg))))
+
+;;; List predicates
+
+(fset 'not #'null)
+
+(defun atom (object)
+ (null (consp object)))
+
+(defun nlistp (object)
+ (null (listp object)))
+
+;;; Lists
+
+(fset 'cons (@ (guile) cons))
+(fset 'list (@ (guile) list))
+(fset 'make-list (@ (guile) make-list))
+(fset 'append (@ (guile) append))
+(fset 'reverse (@ (guile) reverse))
+(fset 'nreverse (@ (guile) reverse!))
+
+(defun car-safe (object)
+ (if (consp object)
+ (car object)
+ nil))
+
+(defun cdr-safe (object)
+ (if (consp object)
+ (cdr object)
+ nil))
+
+(defun setcar (cell newcar)
+ (if (consp cell)
+ (progn
+ (funcall (@ (guile) set-car!) cell newcar)
+ newcar)
+ (signal 'wrong-type-argument `(consp ,cell))))
+
+(defun setcdr (cell newcdr)
+ (if (consp cell)
+ (progn
+ (funcall (@ (guile) set-cdr!) cell newcdr)
+ newcdr)
+ (signal 'wrong-type-argument `(consp ,cell))))
+
+(defun nthcdr (n list)
+ (let ((i 0))
+ (while (< i n)
+ (setq list (cdr list)
+ i (+ i 1)))
+ list))
+
+(defun nth (n list)
+ (car (nthcdr n list)))
+
+(defun %member (elt list test)
+ (cond
+ ((null list) nil)
+ ((consp list)
+ (if (funcall test elt (car list))
+ list
+ (%member elt (cdr list) test)))
+ (t (signal 'wrong-type-argument `(listp ,list)))))
+
+(defun member (elt list)
+ (%member elt list #'equal))
+
+(defun memql (elt list)
+ (%member elt list #'eql))
+
+(defun memq (elt list)
+ (%member elt list #'eq))
+
+(defun assoc (key list)
+ (funcall (@ (srfi srfi-1) assoc) key list #'equal))
+
+(defun assq (key list)
+ (funcall (@ (srfi srfi-1) assoc) key list #'eq))
+
+(defun rplaca (cell newcar)
+ (funcall (@ (guile) set-car!) cell newcar)
+ newcar)
+
+(defun rplacd (cell newcdr)
+ (funcall (@ (guile) set-cdr!) cell newcdr)
+ newcdr)
+
+(defun caar (x)
+ (car (car x)))
+
+(defun cadr (x)
+ (car (cdr x)))
+
+(defun cdar (x)
+ (cdr (car x)))
+
+(defun cddr (x)
+ (cdr (cdr x)))
+
+(defmacro dolist (spec &rest body)
+ (apply #'(lambda (var list &optional result)
+ `(mapc #'(lambda (,var)
+ ,@body
+ ,result)
+ ,list))
+ spec))
+
+;;; Strings
+
+(defun string (&rest characters)
+ (funcall (@ (guile) list->string)
+ (mapcar (@ (guile) integer->char) characters)))
+
+(defun stringp (object)
+ (funcall (@ (guile) string?) object))
+
+(defun string-equal (s1 s2)
+ (let ((s1 (if (symbolp s1) (symbol-name s1) s1))
+ (s2 (if (symbolp s2) (symbol-name s2) s2)))
+ (funcall (@ (guile) string=?) s1 s2)))
+
+(fset 'string= 'string-equal)
+
+(defun substring (string from &optional to)
+ (apply (@ (guile) substring) string from (if to (list to) nil)))
+
+(defun upcase (obj)
+ (funcall (@ (guile) string-upcase) obj))
+
+(defun downcase (obj)
+ (funcall (@ (guile) string-downcase) obj))
+
+(defun string-match (regexp string &optional start)
+ (let ((m (funcall (@ (ice-9 regex) string-match)
+ regexp
+ string
+ (or start 0))))
+ (if m
+ (funcall (@ (ice-9 regex) match:start) m 0)
+ nil)))
+
+;; Vectors
+
+(defun make-vector (length init)
+ (funcall (@ (guile) make-vector) length init))
+
+;;; Sequences
+
+(defun length (sequence)
+ (funcall (if (listp sequence)
+ (@ (guile) length)
+ (@ (guile) generalized-vector-length))
+ sequence))
+
+(defun mapcar (function sequence)
+ (funcall (@ (guile) map) function sequence))
+
+(defun mapc (function sequence)
+ (funcall (@ (guile) for-each) function sequence)
+ sequence)
+
+(defun aref (array idx)
+ (funcall (@ (guile) generalized-vector-ref) array idx))
+
+(defun aset (array idx newelt)
+ (funcall (@ (guile) generalized-vector-set!) array idx newelt)
+ newelt)
+
+(defun concat (&rest sequences)
+ (apply (@ (guile) string-append) sequences))
+
+;;; Property lists
+
+(defun %plist-member (plist property test)
+ (cond
+ ((null plist) nil)
+ ((consp plist)
+ (if (funcall test (car plist) property)
+ (cdr plist)
+ (%plist-member (cdr (cdr plist)) property test)))
+ (t (signal 'wrong-type-argument `(listp ,plist)))))
+
+(defun %plist-get (plist property test)
+ (car (%plist-member plist property test)))
+
+(defun %plist-put (plist property value test)
+ (let ((x (%plist-member plist property test)))
+ (if x
+ (progn (setcar x value) plist)
+ (cons property (cons value plist)))))
+
+(defun plist-get (plist property)
+ (%plist-get plist property #'eq))
+
+(defun plist-put (plist property value)
+ (%plist-put plist property value #'eq))
+
+(defun plist-member (plist property)
+ (%plist-member plist property #'eq))
+
+(defun lax-plist-get (plist property)
+ (%plist-get plist property #'equal))
+
+(defun lax-plist-put (plist property value)
+ (%plist-put plist property value #'equal))
+
+(defvar plist-function (funcall (@ (guile) make-object-property)))
+
+(defun symbol-plist (symbol)
+ (funcall plist-function symbol))
+
+(defun setplist (symbol plist)
+ (funcall (funcall (@ (guile) setter) plist-function) symbol plist))
+
+(defun get (symbol propname)
+ (plist-get (symbol-plist symbol) propname))
+
+(defun put (symbol propname value)
+ (setplist symbol (plist-put (symbol-plist symbol) propname value)))
+
+;;; Nonlocal exits
+
+(defmacro condition-case (var bodyform &rest handlers)
+ (let ((key (make-symbol "key"))
+ (error-symbol (make-symbol "error-symbol"))
+ (data (make-symbol "data"))
+ (conditions (make-symbol "conditions")))
+ (flet ((handler->cond-clause (handler)
+ `((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions))
+ (if (consp (car handler))
+ (car handler)
+ (list (car handler)))))
+ ,@(cdr handler))))
+ `(funcall (@ (guile) catch)
+ 'elisp-condition
+ #'(lambda () ,bodyform)
+ #'(lambda (,key ,error-symbol ,data)
+ (declare (lexical ,key ,error-symbol ,data))
+ (let ((,conditions
+ (get ,error-symbol 'error-conditions))
+ ,@(if var
+ `((,var (cons ,error-symbol ,data)))
+ '()))
+ (declare (lexical ,conditions
+ ,@(if var `(,var) '())))
+ (cond ,@(mapcar #'handler->cond-clause handlers)
+ (t (signal ,error-symbol ,data)))))))))
+
+(put 'error 'error-conditions '(error))
+(put 'wrong-type-argument 'error-conditions '(wrong-type-argument error))
+(put 'invalid-function 'error-conditions '(invalid-function error))
+(put 'no-catch 'error-conditions '(no-catch error))
+(put 'throw 'error-conditions '(throw))
+
+(defvar %catch nil)
+
+(defmacro catch (tag &rest body)
+ (let ((tag-value (make-symbol "tag-value"))
+ (c (make-symbol "c"))
+ (data (make-symbol "data")))
+ `(let ((,tag-value ,tag))
+ (declare (lexical ,tag-value))
+ (condition-case ,c
+ (let ((%catch t))
+ ,@body)
+ (throw
+ (let ((,data (cdr ,c)))
+ (declare (lexical ,data))
+ (if (eq (car ,data) ,tag-value)
+ (car (cdr ,data))
+ (apply #'throw ,data))))))))
+
+(defun throw (tag value)
+ (signal (if %catch 'throw 'no-catch) (list tag value)))
+
+;;; I/O
+
+(defun princ (object)
+ (funcall (@ (guile) display) object))
+
+(defun print (object)
+ (funcall (@ (guile) write) object))
+
+(defun terpri ()
+ (funcall (@ (guile) newline)))
+
+(defun format* (stream string &rest args)
+ (apply (@ (guile) format) stream string args))
+
+(defun send-string-to-terminal (string)
+ (princ string))
+
+(defun read-from-minibuffer (prompt &rest ignore)
+ (princ prompt)
+ (let ((value (funcall (@ (ice-9 rdelim) read-line))))
+ (if (funcall (@ (guile) eof-object?) value)
+ ""
+ value)))
+
+(defun prin1-to-string (object)
+ (format* nil "~S" object))
+
+;; Random number generation
+
+(defvar %random-state (funcall (@ (guile) copy-random-state)
+ (@ (guile) *random-state*)))
+
+(defun random (&optional limit)
+ (if (eq limit t)
+ (setq %random-state
+ (funcall (@ (guile) random-state-from-platform))))
+ (funcall (@ (guile) random)
+ (if (wholenump limit)
+ limit
+ (@ (guile) most-positive-fixnum))
+ %random-state))
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 0df21c7e6..1a4d00faa 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -31,26 +31,24 @@
#:use-module (srfi srfi-26)
#:export (compile-tree-il
compile-progn
+ compile-eval-when-compile
compile-if
compile-defconst
compile-defvar
compile-setq
compile-let
- compile-lexical-let
compile-flet
+ compile-labels
compile-let*
- compile-lexical-let*
- compile-flet*
- compile-without-void-checks
- compile-with-always-lexical
compile-guile-ref
compile-guile-primitive
- compile-while
compile-function
compile-defmacro
compile-defun
#{compile-`}#
- compile-quote))
+ compile-quote
+ compile-%funcall
+ compile-%set-lexical-binding-mode))
;;; Certain common parameters (like the bindings data structure or
;;; compiler options) are not always passed around but accessed using
@@ -61,14 +59,7 @@
(define bindings-data (make-fluid))
-;;; Store for which symbols (or all/none) void checks are disabled.
-
-(define disable-void-check (make-fluid))
-
-;;; Store which symbols (or all/none) should always be bound lexically,
-;;; even with ordinary let and as lambda arguments.
-
-(define always-lexical (make-fluid))
+(define lexical-binding (make-fluid))
;;; Find the source properties of some parsed expression if there are
;;; any associated with it.
@@ -109,7 +100,7 @@
;;; Build a call to a primitive procedure nicely.
(define (call-primitive loc sym . args)
- (make-application loc (make-primitive-ref loc sym) args))
+ (make-primcall loc sym args))
;;; Error reporting routine for syntax/compilation problems or build
;;; code for a runtime-error output.
@@ -117,422 +108,253 @@
(define (report-error loc . args)
(apply error args))
-(define (runtime-error loc msg . args)
- (make-application loc
- (make-primitive-ref loc 'error)
- (cons (make-const loc msg) args)))
-
-;;; Generate code to ensure a global symbol is there for further use of
-;;; a given symbol. In general during the compilation, those needed are
-;;; only tracked with the bindings data structure. Afterwards, however,
-;;; for all those needed symbols the globals are really generated with
-;;; this routine.
-
-(define (generate-ensure-global loc sym module)
- (make-application loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
-
-(define (ensuring-globals loc bindings body)
- (make-sequence
- loc
- `(,@(map-globals-needed (fluid-ref bindings)
- (lambda (mod sym)
- (generate-ensure-global loc sym mod)))
- ,body)))
-
-;;; Build a construct that establishes dynamic bindings for certain
-;;; variables. We may want to choose between binding with fluids and
-;;; with-fluids* and using just ordinary module symbols and
-;;; setting/reverting their values with a dynamic-wind.
-
-(define (let-dynamic loc syms module vals body)
- (call-primitive
- loc
- 'with-fluids*
- (make-application loc
- (make-primitive-ref loc 'list)
- (map (lambda (sym)
- (make-module-ref loc module sym #t))
- syms))
- (make-application loc (make-primitive-ref loc 'list) vals)
- (make-lambda loc
- '()
- (make-lambda-case #f '() #f #f #f '() '() body #f))))
-
-;;; Handle access to a variable (reference/setting) correctly depending
-;;; on whether it is currently lexically or dynamically bound. lexical
-;;; access is done only for references to the value-slot module!
-
-(define (access-variable loc
- sym
- module
- handle-global
- handle-lexical
- handle-dynamic)
- (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
- (cond
- (lexical (handle-lexical lexical))
- ((equal? module function-slot) (handle-global))
- (else (handle-dynamic)))))
-
-;;; Generate code to reference a variable. For references in the
-;;; value-slot module, we may want to generate a lexical reference
-;;; instead if the variable has a lexical binding.
+(define (access-variable loc symbol handle-lexical handle-dynamic)
+ (cond
+ ((get-lexical-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-dynamic))))
-(define (reference-variable loc sym module)
+(define (reference-variable loc symbol)
(access-variable
loc
- sym
- module
- (lambda () (make-module-ref loc module sym #t))
- (lambda (lexical) (make-lexical-ref loc lexical lexical))
+ symbol
+ (lambda (lexical)
+ (make-lexical-ref loc lexical lexical))
(lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc
'fluid-ref
- (make-module-ref loc module sym #t)))))
-
-;;; Generate code to set a variable. Just as with reference-variable, in
-;;; case of a reference to value-slot, we want to generate a lexical set
-;;; when the variable has a lexical binding.
-
-(define (set-variable! loc sym module value)
+ (make-module-ref loc value-slot symbol #t)))))
+
+(define (global? module symbol)
+ (module-variable module symbol))
+
+(define (ensure-globals! loc names body)
+ (if (and (every (cut global? (resolve-module value-slot) <>) names)
+ (every symbol-interned? names))
+ body
+ (list->seq
+ loc
+ `(,@(map
+ (lambda (name)
+ (ensure-fluid! value-slot name)
+ (make-call loc
+ (make-module-ref loc runtime 'ensure-fluid! #t)
+ (list (make-const loc value-slot)
+ (make-const loc name))))
+ names)
+ ,body))))
+
+(define (set-variable! loc symbol value)
(access-variable
loc
- sym
- module
+ symbol
+ (lambda (lexical)
+ (make-lexical-set loc lexical lexical value))
(lambda ()
- (make-application
+ (ensure-globals!
loc
- (make-module-ref loc runtime 'set-variable! #t)
- (list (make-const loc module) (make-const loc sym) value)))
- (lambda (lexical) (make-lexical-set loc lexical lexical value))
+ (list symbol)
+ (call-primitive loc
+ 'fluid-set!
+ (make-module-ref loc value-slot symbol #t)
+ value)))))
+
+(define (access-function loc symbol handle-lexical handle-global)
+ (cond
+ ((get-function-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-global))))
+
+(define (reference-function loc symbol)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-ref loc symbol gensym))
+ (lambda () (make-module-ref loc function-slot symbol #t))))
+
+(define (set-function! loc symbol value)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-set loc symbol gensym value))
(lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc
- 'fluid-set!
- (make-module-ref loc module sym #t)
- value))))
-
-;;; Process the bindings part of a let or let* expression; that is,
-;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
-;;; . val2) ...).
-
-(define (process-let-bindings loc bindings)
- (map
- (lambda (b)
- (if (symbol? b)
- (cons b 'nil)
- (if (or (not (list? b))
- (not (= (length b) 2)))
- (report-error
- loc
- "expected symbol or list of 2 elements in let")
- (if (not (symbol? (car b)))
- (report-error loc "expected symbol in let")
- (cons (car b) (cadr b))))))
- bindings))
-
-;;; Split the let bindings into a list to be done lexically and one
-;;; dynamically. A symbol will be bound lexically if and only if: We're
-;;; processing a lexical-let (i.e. module is 'lexical), OR we're
-;;; processing a value-slot binding AND the symbol is already lexically
-;;; bound or is always lexical, OR we're processing a function-slot
-;;; binding.
-
-(define (bind-lexically? sym module)
- (or (eq? module 'lexical)
- (eq? module function-slot)
- (and (equal? module value-slot)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (memq sym always)
- (get-lexical-binding (fluid-ref bindings-data) sym))))))
-
-(define (split-let-bindings bindings module)
- (let iterate ((tail bindings)
- (lexical '())
- (dynamic '()))
- (if (null? tail)
- (values (reverse lexical) (reverse dynamic))
- (if (bind-lexically? (caar tail) module)
- (iterate (cdr tail) (cons (car tail) lexical) dynamic)
- (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
-
-;;; Compile let and let* expressions. The code here is used both for
-;;; let/let* and flet/flet*, just with a different bindings module.
-;;;
-;;; A special module value 'lexical means that we're doing a lexical-let
-;;; instead and the bindings should not be saved to globals at all but
-;;; be done with the lexical framework instead.
-
-;;; Let is done with a single call to let-dynamic binding them locally
-;;; to new values all "at once". If there is at least one variable to
-;;; bind lexically among the bindings, we first do a let for all of them
-;;; to evaluate all values before any bindings take place, and then call
-;;; let-dynamic for the variables to bind dynamically.
-
-(define (generate-let loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (call-with-values
- (lambda () (split-let-bindings bind module))
- (lambda (lexical dynamic)
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module))
- (map car dynamic))
- (let ((make-values (lambda (for)
- (map (lambda (el) (compile-expr (cdr el)))
- for)))
- (make-body (lambda ()
- (make-sequence loc (map compile-expr body)))))
- (if (null? lexical)
- (let-dynamic loc (map car dynamic) module
- (make-values dynamic) (make-body))
- (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
- (dynamic-syms (map (lambda (el) (gensym)) dynamic))
- (all-syms (append lexical-syms dynamic-syms))
- (vals (append (make-values lexical)
- (make-values dynamic))))
- (make-let loc
- all-syms
- all-syms
- vals
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car lexical) lexical-syms
- (lambda ()
- (if (null? dynamic)
- (make-body)
- (let-dynamic loc
- (map car dynamic)
- module
- (map
- (lambda (sym)
- (make-lexical-ref loc
- sym
- sym))
- dynamic-syms)
- (make-body)))))))))))))
-
-;;; Let* is compiled to a cascaded set of "small lets" for each binding
-;;; in turn so that each one already sees the preceding bindings.
-
-(define (generate-let* loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (begin
- (for-each (lambda (sym)
- (if (not (bind-lexically? sym module))
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module)))
- (map car bind))
- (let iterate ((tail bind))
- (if (null? tail)
- (make-sequence loc (map compile-expr body))
- (let ((sym (caar tail))
- (value (compile-expr (cdar tail))))
- (if (bind-lexically? sym module)
- (let ((target (gensym)))
- (make-let loc
- `(,target)
- `(,target)
- `(,value)
- (with-lexical-bindings
- (fluid-ref bindings-data)
- `(,sym)
- `(,target)
- (lambda () (iterate (cdr tail))))))
- (let-dynamic loc
- `(,(caar tail))
- module
- `(,value)
- (iterate (cdr tail))))))))))
-
-;;; Split the argument list of a lambda expression into required,
-;;; optional and rest arguments and also check it is actually valid.
-;;; Additionally, we create a list of all "local variables" (that is,
-;;; required, optional and rest arguments together) and also this one
-;;; split into those to be bound lexically and dynamically. Returned is
-;;; as multiple values: required optional rest lexical dynamic
-
-(define (bind-arg-lexical? arg)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (memq arg always))))
-
-(define (split-lambda-arguments loc args)
- (let iterate ((tail args)
- (mode 'required)
- (required '())
- (optional '())
- (lexical '())
- (dynamic '()))
- (cond
- ((null? tail)
- (let ((final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse lexical))
- (final-dynamic (reverse dynamic)))
- (values final-required
- final-optional
- #f
- final-lexical
- final-dynamic)))
- ((and (eq? mode 'required)
- (eq? (car tail) '&optional))
- (iterate (cdr tail) 'optional required optional lexical dynamic))
- ((eq? (car tail) '&rest)
- (if (or (null? (cdr tail))
- (not (null? (cddr tail))))
- (report-error loc "expected exactly one symbol after &rest")
- (let* ((rest (cadr tail))
- (rest-lexical (bind-arg-lexical? rest))
- (final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse (if rest-lexical
- (cons rest lexical)
- lexical)))
- (final-dynamic (reverse (if rest-lexical
- dynamic
- (cons rest dynamic)))))
- (values final-required
- final-optional
- rest
- final-lexical
- final-dynamic))))
- (else
- (if (not (symbol? (car tail)))
- (report-error loc
- "expected symbol in argument list, got"
- (car tail))
- (let* ((arg (car tail))
- (bind-lexical (bind-arg-lexical? arg))
- (new-lexical (if bind-lexical
- (cons arg lexical)
- lexical))
- (new-dynamic (if bind-lexical
- dynamic
- (cons arg dynamic))))
- (case mode
- ((required) (iterate (cdr tail) mode
- (cons arg required) optional
- new-lexical new-dynamic))
- ((optional) (iterate (cdr tail) mode
- required (cons arg optional)
- new-lexical new-dynamic))
- (else
- (error "invalid mode in split-lambda-arguments"
- mode)))))))))
-
-;;; Compile a lambda expression. One thing we have to be aware of is
-;;; that lambda arguments are usually dynamically bound, even when a
-;;; lexical binding is intact for a symbol. For symbols that are marked
-;;; as 'always lexical,' however, we lexically bind here as well, and
-;;; thus we get them out of the let-dynamic call and register a lexical
-;;; binding for them (the lexical target variable is already there,
-;;; namely the real lambda argument from TreeIL).
-
-(define (compile-lambda loc args body)
- (if (not (list? args))
- (report-error loc "expected list for argument-list" args))
- (if (null? body)
- (report-error loc "function body must not be empty"))
- (receive (required optional rest lexical dynamic)
- (split-lambda-arguments loc args)
- (define (process-args args)
- (define (find-pairs pairs filter)
- (lset-intersection (lambda (name+sym x)
- (eq? (car name+sym) x))
- pairs
- filter))
- (let* ((syms (map (lambda (x) (gensym)) args))
- (pairs (map cons args syms))
- (lexical-pairs (find-pairs pairs lexical))
- (dynamic-pairs (find-pairs pairs dynamic)))
- (values syms pairs lexical-pairs dynamic-pairs)))
- (let*-values (((required-syms
- required-pairs
- required-lex-pairs
- required-dyn-pairs)
- (process-args required))
- ((optional-syms
- optional-pairs
- optional-lex-pairs
- optional-dyn-pairs)
- (process-args optional))
- ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
- (process-args (if rest (list rest) '())))
- ((the-rest-sym) (if rest (car rest-syms) #f))
- ((all-syms) (append required-syms
- optional-syms
- rest-syms))
- ((all-lex-pairs) (append required-lex-pairs
- optional-lex-pairs
- rest-lex-pairs))
- ((all-dyn-pairs) (append required-dyn-pairs
- optional-dyn-pairs
- rest-dyn-pairs)))
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- value-slot))
- dynamic)
- (with-dynamic-bindings
- (fluid-ref bindings-data)
- dynamic
- (lambda ()
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car all-lex-pairs)
- (map cdr all-lex-pairs)
- (lambda ()
- (make-lambda
- loc
- '()
- (make-lambda-case
- #f
- required
- optional
- rest
- #f
- (map (lambda (x) (nil-value loc)) optional)
- all-syms
- (let ((compiled-body
- (make-sequence loc (map compile-expr body))))
- (make-sequence
- loc
- (list
- (if rest
- (make-conditional
- loc
- (call-primitive loc
- 'null?
- (make-lexical-ref loc
- rest
- the-rest-sym))
- (make-lexical-set loc
- rest
- the-rest-sym
- (nil-value loc))
- (make-void loc))
- (make-void loc))
- (if (null? dynamic)
- compiled-body
- (let-dynamic loc
- dynamic
- value-slot
- (map (lambda (name-sym)
- (make-lexical-ref
- loc
- (car name-sym)
- (cdr name-sym)))
- all-dyn-pairs)
- compiled-body)))))
- #f)))))))))
+ (make-call
+ loc
+ (make-module-ref loc runtime 'set-symbol-function! #t)
+ (list (make-const loc symbol) value)))))
+
+(define (bind-lexically? sym module decls)
+ (or (eq? module function-slot)
+ (let ((decl (assq-ref decls sym)))
+ (and (equal? module value-slot)
+ (or
+ (eq? decl 'lexical)
+ (and
+ (fluid-ref lexical-binding)
+ (not (global? (resolve-module module) sym))))))))
+
+(define (parse-let-binding loc binding)
+ (pmatch binding
+ ((unquote var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var ,val)
+ (guard (symbol? var))
+ (cons var val))
+ (else
+ (report-error loc "malformed variable binding" binding))))
+
+(define (parse-flet-binding loc binding)
+ (pmatch binding
+ ((,var ,args . ,body)
+ (guard (symbol? var))
+ (cons var `(function (lambda ,args ,@body))))
+ (else
+ (report-error loc "malformed function binding" binding))))
+
+(define (parse-declaration expr)
+ (pmatch expr
+ ((lexical . ,vars)
+ (map (cut cons <> 'lexical) vars))
+ (else
+ '())))
+
+(define (parse-body-1 body lambda?)
+ (let loop ((lst body)
+ (decls '())
+ (intspec #f)
+ (doc #f))
+ (pmatch lst
+ (((declare . ,x) . ,tail)
+ (loop tail (append-reverse x decls) intspec doc))
+ (((interactive . ,x) . ,tail)
+ (guard lambda? (not intspec))
+ (loop tail decls x doc))
+ ((,x . ,tail)
+ (guard lambda? (string? x) (not doc) (not (null? tail)))
+ (loop tail decls intspec x))
+ (else
+ (values (append-map parse-declaration decls)
+ intspec
+ doc
+ lst)))))
+
+(define (parse-lambda-body body)
+ (parse-body-1 body #t))
+
+(define (parse-body body)
+ (receive (decls intspec doc body) (parse-body-1 body #f)
+ (values decls body)))
+
+;;; Partition the argument list of a lambda expression into required,
+;;; optional and rest arguments.
+
+(define (parse-lambda-list lst)
+ (define (%match lst null optional rest symbol)
+ (pmatch lst
+ (() (null))
+ ((&optional . ,tail) (optional tail))
+ ((&rest . ,tail) (rest tail))
+ ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
+ (else (fail))))
+ (define (return rreq ropt rest)
+ (values #t (reverse rreq) (reverse ropt) rest))
+ (define (fail)
+ (values #f #f #f #f))
+ (define (parse-req lst rreq)
+ (%match lst
+ (lambda () (return rreq '() #f))
+ (lambda (tail) (parse-opt tail rreq '()))
+ (lambda (tail) (parse-rest tail rreq '()))
+ (lambda (arg tail) (parse-req tail (cons arg rreq)))))
+ (define (parse-opt lst rreq ropt)
+ (%match lst
+ (lambda () (return rreq ropt #f))
+ (lambda (tail) (fail))
+ (lambda (tail) (parse-rest tail rreq ropt))
+ (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
+ (define (parse-rest lst rreq ropt)
+ (%match lst
+ (lambda () (fail))
+ (lambda (tail) (fail))
+ (lambda (tail) (fail))
+ (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
+ (define (parse-post-rest lst rreq ropt rest)
+ (%match lst
+ (lambda () (return rreq ropt rest))
+ (lambda () (fail))
+ (lambda () (fail))
+ (lambda (arg tail) (fail))))
+ (parse-req lst '()))
+
+(define (make-simple-lambda loc meta req opt init rest vars body)
+ (make-lambda loc
+ meta
+ (make-lambda-case #f req opt rest #f init vars body #f)))
+
+(define (compile-lambda loc meta args body)
+ (receive (valid? req-ids opt-ids rest-id)
+ (parse-lambda-list args)
+ (if valid?
+ (let* ((all-ids (append req-ids
+ opt-ids
+ (or (and=> rest-id list) '())))
+ (all-vars (map (lambda (ignore) (gensym)) all-ids)))
+ (let*-values (((decls intspec doc forms)
+ (parse-lambda-body body))
+ ((lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ (map list all-ids all-vars)))
+ ((lexical-ids lexical-vars) (unzip2 lexical))
+ ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
+ (with-dynamic-bindings
+ (fluid-ref bindings-data)
+ dynamic-ids
+ (lambda ()
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ lexical-ids
+ lexical-vars
+ (lambda ()
+ (ensure-globals!
+ loc
+ dynamic-ids
+ (let* ((tree-il
+ (compile-expr
+ (if rest-id
+ `(let ((,rest-id (if ,rest-id
+ ,rest-id
+ nil)))
+ ,@forms)
+ `(progn ,@forms))))
+ (full-body
+ (if (null? dynamic)
+ tree-il
+ (make-dynlet
+ loc
+ (map (cut make-module-ref loc value-slot <> #t)
+ dynamic-ids)
+ (map (cut make-lexical-ref loc <> <>)
+ dynamic-ids
+ dynamic-vars)
+ tree-il))))
+ (make-simple-lambda loc
+ meta
+ req-ids
+ opt-ids
+ (map (const (nil-value loc))
+ opt-ids)
+ rest-id
+ all-vars
+ full-body)))))))))
+ (report-error "invalid function" `(lambda ,args ,@body)))))
;;; Handle the common part of defconst and defvar, that is, checking for
;;; a correct doc string and arguments as well as maybe in the future
@@ -550,12 +372,11 @@
;;; Handle macro and special operator bindings.
-(define (find-operator sym type)
+(define (find-operator name type)
(and
- (symbol? sym)
- (module-defined? (resolve-interface function-slot) sym)
- (let* ((op (module-ref (resolve-module function-slot) sym))
- (op (if (fluid? op) (fluid-ref op) op)))
+ (symbol? name)
+ (module-defined? (resolve-interface function-slot) name)
+ (let ((op (module-ref (resolve-module function-slot) name)))
(if (and (pair? op) (eq? (car op) type))
(cdr op)
#f))))
@@ -611,87 +432,67 @@
expr))
(make-const loc expr)))
-;;; Temporarily update a list of symbols that are handled specially
-;;; (disabled void check or always lexical) for compiling body. We need
-;;; to handle special cases for already all / set to all and the like.
-
-(define (with-added-symbols loc fluid syms body)
- (if (null? body)
- (report-error loc "symbol-list construct has empty body"))
- (if (not (or (eq? syms 'all)
- (and (list? syms) (and-map symbol? syms))))
- (report-error loc "invalid symbol list" syms))
- (let ((old (fluid-ref fluid))
- (make-body (lambda ()
- (make-sequence loc (map compile-expr body)))))
- (if (eq? old 'all)
- (make-body)
- (let ((new (if (eq? syms 'all)
- 'all
- (append syms old))))
- (with-fluids ((fluid new))
- (make-body))))))
-
;;; Special operators
(defspecial progn (loc args)
- (make-sequence loc (map compile-expr args)))
+ (list->seq loc
+ (if (null? args)
+ (list (nil-value loc))
+ (map compile-expr args))))
+
+(defspecial eval-when-compile (loc args)
+ (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
(defspecial if (loc args)
(pmatch args
((,cond ,then . ,else)
- (make-conditional loc
- (compile-expr cond)
- (compile-expr then)
- (if (null? else)
- (nil-value loc)
- (make-sequence loc
- (map compile-expr else)))))))
+ (make-conditional
+ loc
+ (call-primitive loc 'not
+ (call-primitive loc 'nil? (compile-expr cond)))
+ (compile-expr then)
+ (compile-expr `(progn ,@else))))))
(defspecial defconst (loc args)
(pmatch args
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence loc
- (list (set-variable! loc
- sym
- value-slot
- (compile-expr value))
- (make-const loc sym)))))))
+ (make-seq loc
+ (set-variable! loc sym (compile-expr value))
+ (make-const loc sym))))))
(defspecial defvar (loc args)
(pmatch args
((,sym) (make-const loc sym))
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence
+ (make-seq
loc
- (list
+ (make-conditional
+ loc
(make-conditional
loc
- (make-conditional
+ (call-primitive
loc
- (call-primitive
- loc
- 'module-bound?
- (call-primitive loc
- 'resolve-interface
- (make-const loc value-slot))
- (make-const loc sym))
+ 'module-bound?
(call-primitive loc
- 'fluid-bound?
- (make-module-ref loc value-slot sym #t))
- (make-const loc #f))
- (make-void loc)
- (set-variable! loc sym value-slot (compile-expr value)))
- (make-const loc sym)))))))
+ 'resolve-interface
+ (make-const loc value-slot))
+ (make-const loc sym))
+ (call-primitive loc
+ 'fluid-bound?
+ (make-module-ref loc value-slot sym #t))
+ (make-const loc #f))
+ (make-void loc)
+ (set-variable! loc sym (compile-expr value)))
+ (make-const loc sym))))))
(defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x)))
(define (cdr* x) (if (null? x) '() (cdr x)))
(define (cadr* x) (car* (cdr* x)))
(define (cddr* x) (cdr* (cdr* x)))
- (make-sequence
+ (list->seq
loc
(let loop ((args args) (last (nil-value loc)))
(if (null? args)
@@ -701,47 +502,141 @@
(if (not (symbol? sym))
(report-error loc "expected symbol in setq")
(cons
- (set-variable! loc sym value-slot val)
+ (set-variable! loc sym val)
(loop (cddr* args)
- (reference-variable loc sym value-slot)))))))))
+ (reference-variable loc sym)))))))))
(defspecial let (loc args)
(pmatch args
- ((,bindings . ,body)
- (generate-let loc value-slot bindings body))))
-
-(defspecial lexical-let (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc 'lexical bindings body))))
-
-(defspecial flet (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc function-slot bindings body))))
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (receive (lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ bindings)
+ (let ((make-values (lambda (for)
+ (map (lambda (el) (compile-expr (cdr el)))
+ for)))
+ (make-body (lambda () (compile-expr `(progn ,@forms)))))
+ (ensure-globals!
+ loc
+ (map car dynamic)
+ (if (null? lexical)
+ (make-dynlet loc
+ (map (compose (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map (compose compile-expr cdr)
+ dynamic)
+ (make-body))
+ (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
+ (dynamic-syms (map (lambda (el) (gensym)) dynamic))
+ (all-syms (append lexical-syms dynamic-syms))
+ (vals (append (make-values lexical)
+ (make-values dynamic))))
+ (make-let loc
+ all-syms
+ all-syms
+ vals
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ (map car lexical)
+ lexical-syms
+ (lambda ()
+ (if (null? dynamic)
+ (make-body)
+ (make-dynlet loc
+ (map
+ (compose
+ (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map
+ (lambda (sym)
+ (make-lexical-ref
+ loc
+ sym
+ sym))
+ dynamic-syms)
+ (make-body))))))))))))))))
(defspecial let* (loc args)
(pmatch args
- ((,bindings . ,body)
- (generate-let* loc value-slot bindings body))))
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (let iterate ((tail bindings))
+ (if (null? tail)
+ (compile-expr `(progn ,@forms))
+ (let ((sym (caar tail))
+ (value (compile-expr (cdar tail))))
+ (if (bind-lexically? sym value-slot decls)
+ (let ((target (gensym)))
+ (make-let loc
+ `(,target)
+ `(,target)
+ `(,value)
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ `(,sym)
+ `(,target)
+ (lambda () (iterate (cdr tail))))))
+ (ensure-globals!
+ loc
+ (list sym)
+ (make-dynlet loc
+ (list (make-module-ref loc value-slot sym #t))
+ (list value)
+ (iterate (cdr tail)))))))))))))
-(defspecial lexical-let* (loc args)
+(defspecial flet (loc args)
(pmatch args
((,bindings . ,body)
- (generate-let* loc 'lexical bindings body))))
-
-(defspecial flet* (loc args)
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-let loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
+
+(defspecial labels (loc args)
(pmatch args
((,bindings . ,body)
- (generate-let* loc function-slot bindings body))))
-
-;;; Temporarily set symbols as always lexical only for the lexical scope
-;;; of a construct.
-
-(defspecial with-always-lexical (loc args)
- (pmatch args
- ((,syms . ,body)
- (with-added-symbols loc always-lexical syms body))))
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-letrec #f
+ loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
;;; guile-ref allows building TreeIL's module references from within
;;; elisp as a way to access data within the Guile universe. The module
@@ -761,59 +656,12 @@
((,sym)
(make-primitive-ref loc sym))))
-;;; A while construct is transformed into a tail-recursive loop like
-;;; this:
-;;;
-;;; (letrec ((iterate (lambda ()
-;;; (if condition
-;;; (begin body
-;;; (iterate))
-;;; #nil))))
-;;; (iterate))
-;;;
-;;; As letrec is not directly accessible from elisp, while is
-;;; implemented here instead of with a macro.
-
-(defspecial while (loc args)
- (pmatch args
- ((,condition . ,body)
- (let* ((itersym (gensym))
- (compiled-body (map compile-expr body))
- (iter-call (make-application loc
- (make-lexical-ref loc
- 'iterate
- itersym)
- (list)))
- (full-body (make-sequence loc
- `(,@compiled-body ,iter-call)))
- (lambda-body (make-conditional loc
- (compile-expr condition)
- full-body
- (nil-value loc)))
- (iter-thunk (make-lambda loc
- '()
- (make-lambda-case #f
- '()
- #f
- #f
- #f
- '()
- '()
- lambda-body
- #f))))
- (make-letrec loc
- #f
- '(iterate)
- (list itersym)
- (list iter-thunk)
- iter-call)))))
-
(defspecial function (loc args)
(pmatch args
(((lambda ,args . ,body))
- (compile-lambda loc args body))
+ (compile-lambda loc '() args body))
((,sym) (guard (symbol? sym))
- (reference-variable loc sym function-slot))))
+ (reference-function loc sym))))
(defspecial defmacro (loc args)
(pmatch args
@@ -821,22 +669,21 @@
(if (not (symbol? name))
(report-error loc "expected symbol as macro name" name)
(let* ((tree-il
- (make-sequence
+ (make-seq
loc
- (list
- (set-variable!
+ (set-function!
+ loc
+ name
+ (make-call
loc
- name
- function-slot
- (make-application
- loc
- (make-module-ref loc '(guile) 'cons #t)
- (list (make-const loc 'macro)
- (compile-lambda loc args body))))
- (make-const loc name)))))
- (compile (ensuring-globals loc bindings-data tree-il)
- #:from 'tree-il
- #:to 'value)
+ (make-module-ref loc '(guile) 'cons #t)
+ (list (make-const loc 'macro)
+ (compile-lambda loc
+ `((name . ,name))
+ args
+ body))))
+ (make-const loc name))))
+ (compile tree-il #:from 'tree-il #:to 'value)
tree-il)))))
(defspecial defun (loc args)
@@ -844,14 +691,14 @@
((,name ,args . ,body)
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
- (make-sequence loc
- (list (set-variable! loc
- name
- function-slot
- (compile-lambda loc
- args
- body))
- (make-const loc name)))))))
+ (make-seq loc
+ (set-function! loc
+ name
+ (compile-lambda loc
+ `((name . ,name))
+ args
+ body))
+ (make-const loc name))))))
(defspecial #{`}# (loc args)
(pmatch args
@@ -863,6 +710,19 @@
((,val)
(make-const loc val))))
+(defspecial %funcall (loc args)
+ (pmatch args
+ ((,function . ,arguments)
+ (make-call loc
+ (compile-expr function)
+ (map compile-expr arguments)))))
+
+(defspecial %set-lexical-binding-mode (loc args)
+ (pmatch args
+ ((,val)
+ (fluid-set! lexical-binding val)
+ (make-void loc))))
+
;;; Compile a compound expression to Tree-IL.
(define (compile-pair loc expr)
@@ -876,13 +736,7 @@
=> (lambda (macro-function)
(compile-expr (apply macro-function arguments))))
(else
- (make-application loc
- (if (symbol? operator)
- (reference-variable loc
- operator
- function-slot)
- (compile-expr operator))
- (map compile-expr arguments))))))
+ (compile-expr `(%funcall (function ,operator) ,@arguments))))))
;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil.
@@ -891,7 +745,7 @@
(case sym
((nil) (nil-value loc))
((t) (t-value loc))
- (else (reference-variable loc sym value-slot))))
+ (else (reference-variable loc sym))))
;;; Compile a single expression to TreeIL.
@@ -921,28 +775,14 @@
(case key
((#:warnings) ; ignore
#f)
- ((#:always-lexical)
- (if (valid-symbol-list-arg? value)
- (fluid-set! always-lexical value)
- (report-error #f
- "Invalid value for #:always-lexical"
- value)))
(else (report-error #f
"Invalid compiler option"
key)))))))
-;;; Entry point for compilation to TreeIL. This creates the bindings
-;;; data structure, and after compiling the main expression we need to
-;;; make sure all globals for symbols used during the compilation are
-;;; created using the generate-ensure-global function.
-
(define (compile-tree-il expr env opts)
(values
- (with-fluids ((bindings-data (make-bindings))
- (disable-void-check '())
- (always-lexical '()))
+ (with-fluids ((bindings-data (make-bindings)))
(process-options! opts)
- (let ((compiled (compile-expr expr)))
- (ensuring-globals (location expr) bindings-data compiled)))
+ (compile-expr expr))
env
env))
diff --git a/module/language/elisp/falias.scm b/module/language/elisp/falias.scm
new file mode 100644
index 000000000..f043548fb
--- /dev/null
+++ b/module/language/elisp/falias.scm
@@ -0,0 +1,27 @@
+(define-module (language elisp falias)
+ #:export (falias?
+ make-falias
+ falias-function
+ falias-object))
+
+(define <falias-vtable>
+ (make-struct <applicable-struct-vtable>
+ 0
+ (make-struct-layout "pwpw")
+ (lambda (object port)
+ (format port "#<falias ~S>" (falias-object object)))))
+
+(set-struct-vtable-name! <falias-vtable> 'falias)
+
+(define (falias? object)
+ (and (struct? object)
+ (eq? (struct-vtable object) <falias-vtable>)))
+
+(define (make-falias f object)
+ (make-struct <falias-vtable> 0 f object))
+
+(define (falias-function object)
+ (struct-ref object 0))
+
+(define (falias-object object)
+ (struct-ref object 1))
diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm
index af7e02add..1933ff34d 100644
--- a/module/language/elisp/lexer.scm
+++ b/module/language/elisp/lexer.scm
@@ -252,7 +252,15 @@
;;; Main lexer routine, which is given a port and does look for the next
;;; token.
+(define lexical-binding-regexp
+ (make-regexp
+ "-\\*-(|.*;)[ \t]*lexical-binding:[ \t]*([^;]*[^ \t;]).*-\\*-"))
+
(define (lex port)
+ (define (lexical-binding-value string)
+ (and=> (regexp-exec lexical-binding-regexp string)
+ (lambda (match)
+ (not (member (match:substring match 2) '("nil" "()"))))))
(let ((return (let ((file (if (file-port? port)
(port-filename port)
#f))
@@ -283,11 +291,19 @@
(case c
;; A line comment, skip until end-of-line is found.
((#\;)
- (let iterate ()
- (let ((cur (read-char port)))
- (if (or (eof-object? cur) (char=? cur #\newline))
- (lex port)
- (iterate)))))
+ (if (= (port-line port) 0)
+ (let iterate ((chars '()))
+ (let ((cur (read-char port)))
+ (if (or (eof-object? cur) (char=? cur #\newline))
+ (let ((string (list->string (reverse chars))))
+ (return 'set-lexical-binding-mode!
+ (lexical-binding-value string)))
+ (iterate (cons cur chars)))))
+ (let iterate ()
+ (let ((cur (read-char port)))
+ (if (or (eof-object? cur) (char=? cur #\newline))
+ (lex port)
+ (iterate))))))
;; A character literal.
((#\?)
(return 'character (get-character port #f)))
@@ -321,7 +337,12 @@
(let ((mark (get-circular-marker port)))
(return (car mark) (cdr mark))))
((#\')
- (return 'function #f)))))
+ (return 'function #f))
+ ((#\:)
+ (call-with-values
+ (lambda () (get-symbol-or-number port))
+ (lambda (type str)
+ (return 'symbol (make-symbol str))))))))
;; Parentheses and other special-meaning single characters.
((#\() (return 'paren-open #f))
((#\)) (return 'paren-close #f))
diff --git a/module/language/elisp/parser.scm b/module/language/elisp/parser.scm
index df825eb4e..e83f136bb 100644
--- a/module/language/elisp/parser.scm
+++ b/module/language/elisp/parser.scm
@@ -201,6 +201,8 @@
(setter expr)
(force-promises! expr)
expr))
+ ((set-lexical-binding-mode!)
+ (return `(%set-lexical-binding-mode ,(cdr token))))
(else
(parse-error token "expected expression, got" token)))))
diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm
index 0c84d102b..6f6a22074 100644
--- a/module/language/elisp/runtime.scm
+++ b/module/language/elisp/runtime.scm
@@ -25,11 +25,17 @@
function-slot-module
elisp-bool
ensure-fluid!
- reference-variable
- set-variable!
- runtime-error
- macro-error)
- #:export-syntax (built-in-func built-in-macro defspecial prim))
+ symbol-fluid
+ set-symbol-fluid!
+ symbol-value
+ set-symbol-value!
+ symbol-function
+ set-symbol-function!
+ symbol-bound?
+ symbol-fbound?
+ makunbound!
+ fmakunbound!)
+ #:export-syntax (defspecial prim))
;;; This module provides runtime support for the Elisp front-end.
@@ -47,22 +53,6 @@
(define function-slot-module '(language elisp runtime function-slot))
-;;; Report an error during macro compilation, that means some special
-;;; compilation (syntax) error; or report a simple runtime-error from a
-;;; built-in function.
-
-(define (macro-error msg . args)
- (apply error msg args))
-
-(define runtime-error macro-error)
-
-;;; Convert a scheme boolean to Elisp.
-
-(define (elisp-bool b)
- (if b
- t-value
- nil-value))
-
;;; Routines for access to elisp dynamically bound symbols. This is
;;; used for runtime access using functions like symbol-value or set,
;;; where the symbol accessed might not be known at compile-time. These
@@ -77,39 +67,68 @@
(module-define! resolved sym fluid)
(module-export! resolved `(,sym))))))
-(define (reference-variable module sym)
- (let ((resolved (resolve-module module)))
- (cond
- ((equal? module function-slot-module)
- (module-ref resolved sym))
- (else
- (ensure-fluid! module sym)
- (fluid-ref (module-ref resolved sym))))))
+(define (symbol-fluid symbol)
+ (let ((module (resolve-module value-slot-module)))
+ (ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation
+ (module-ref module symbol)))
-(define (set-variable! module sym value)
- (let ((intf (resolve-interface module))
- (resolved (resolve-module module)))
- (cond
- ((equal? module function-slot-module)
- (cond
- ((module-defined? intf sym)
- (module-set! resolved sym value))
- (else
- (module-define! resolved sym value)
- (module-export! resolved `(,sym)))))
- (else
- (ensure-fluid! module sym)
- (fluid-set! (module-ref resolved sym) value))))
+(define (set-symbol-fluid! symbol fluid)
+ (let ((module (resolve-module value-slot-module)))
+ (module-define! module symbol fluid)
+ (module-export! module (list symbol)))
+ fluid)
+
+(define (symbol-value symbol)
+ (fluid-ref (symbol-fluid symbol)))
+
+(define (set-symbol-value! symbol value)
+ (fluid-set! (symbol-fluid symbol) value)
value)
-;;; Define a predefined function or predefined macro for use in the
-;;; function-slot and macro-slot modules, respectively.
+(define (symbol-function symbol)
+ (let ((module (resolve-module function-slot-module)))
+ (module-ref module symbol)))
+
+(define (set-symbol-function! symbol value)
+ (let ((module (resolve-module function-slot-module)))
+ (module-define! module symbol value)
+ (module-export! module (list symbol)))
+ value)
-(define-syntax built-in-func
- (syntax-rules ()
- ((_ name value)
- (begin
- (define-public name value)))))
+(define (symbol-bound? symbol)
+ (and
+ (module-bound? (resolve-interface value-slot-module) symbol)
+ (let ((var (module-variable (resolve-module value-slot-module)
+ symbol)))
+ (and (variable-bound? var)
+ (if (fluid? (variable-ref var))
+ (fluid-bound? (variable-ref var))
+ #t)))))
+
+(define (symbol-fbound? symbol)
+ (and
+ (module-bound? (resolve-interface function-slot-module) symbol)
+ (variable-bound?
+ (module-variable (resolve-module function-slot-module)
+ symbol))))
+
+(define (makunbound! symbol)
+ (if (module-bound? (resolve-interface value-slot-module) symbol)
+ (let ((var (module-variable (resolve-module value-slot-module)
+ symbol)))
+ (if (and (variable-bound? var) (fluid? (variable-ref var)))
+ (fluid-unset! (variable-ref var))
+ (variable-unset! var))))
+ symbol)
+
+(define (fmakunbound! symbol)
+ (if (module-bound? (resolve-interface function-slot-module) symbol)
+ (variable-unset! (module-variable
+ (resolve-module function-slot-module)
+ symbol)))
+ symbol)
+
+;;; Define a predefined macro for use in the function-slot module.
(define (make-id template-id . data)
(let ((append-symbols
@@ -125,30 +144,10 @@
datum))
data)))))
-(define-syntax built-in-macro
- (lambda (x)
- (syntax-case x ()
- ((_ name value)
- (with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
- #'(begin
- (define-public scheme-name
- (make-fluid (cons 'macro value)))))))))
-
(define-syntax defspecial
(lambda (x)
(syntax-case x ()
((_ name args body ...)
(with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
- #'(begin
- (define scheme-name
- (make-fluid
- (cons 'special-operator
- (lambda args body ...))))))))))
-
-;;; Call a guile-primitive that may be rebound for elisp and thus needs
-;;; absolute addressing.
-
-(define-syntax prim
- (syntax-rules ()
- ((_ sym args ...)
- ((@ (guile) sym) args ...))))
+ #'(define scheme-name
+ (cons 'special-operator (lambda args body ...))))))))
diff --git a/module/language/elisp/runtime/function-slot.scm b/module/language/elisp/runtime/function-slot.scm
index 896e3cece..3b10205c1 100644
--- a/module/language/elisp/runtime/function-slot.scm
+++ b/module/language/elisp/runtime/function-slot.scm
@@ -17,142 +17,47 @@
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language elisp runtime function-slot)
- #:use-module (language elisp runtime subrs)
- #:use-module ((language elisp runtime macros)
- #:select
- ((macro-lambda . lambda)
- (macro-prog1 . prog1)
- (macro-prog2 . prog2)
- (macro-when . when)
- (macro-unless . unless)
- (macro-cond . cond)
- (macro-and . and)
- (macro-or . or)
- (macro-dotimes . dotimes)
- (macro-dolist . dolist)
- (macro-catch . catch)
- (macro-unwind-protect . unwind-protect)
- (macro-pop . pop)
- (macro-push . push)))
#:use-module ((language elisp compile-tree-il)
#:select
((compile-progn . progn)
+ (compile-eval-when-compile . eval-when-compile)
(compile-if . if)
(compile-defconst . defconst)
(compile-defvar . defvar)
(compile-setq . setq)
(compile-let . let)
- (compile-lexical-let . lexical-let)
(compile-flet . flet)
+ (compile-labels . labels)
(compile-let* . let*)
- (compile-lexical-let* . lexical-let*)
- (compile-flet* . flet*)
- (compile-with-always-lexical . with-always-lexical)
(compile-guile-ref . guile-ref)
(compile-guile-primitive . guile-primitive)
- (compile-while . while)
(compile-function . function)
(compile-defun . defun)
(compile-defmacro . defmacro)
(#{compile-`}# . #{`}#)
- (compile-quote . quote)))
+ (compile-quote . quote)
+ (compile-%funcall . %funcall)
+ (compile-%set-lexical-binding-mode
+ . %set-lexical-binding-mode)))
#:duplicates (last)
;; special operators
#:re-export (progn
+ eval-when-compile
if
defconst
defvar
setq
let
- lexical-let
flet
+ labels
let*
- lexical-let*
- flet*
- with-always-lexical
guile-ref
guile-primitive
- while
function
defun
defmacro
#{`}#
- quote)
- ;; macros
- #:re-export (lambda
- prog1
- prog2
- when
- unless
- cond
- and
- or
- dotimes
- dolist
- catch
- unwind-protect
- pop
- push)
- ;; functions
- #:re-export (eq
- equal
- floatp
- integerp
- numberp
- wholenump
- zerop
- =
- /=
- <
- <=
- >
- >=
- max
- min
- abs
- float
- 1+
- 1-
- +
- -
- *
- %
- ffloor
- fceiling
- ftruncate
- fround
- consp
- atomp
- listp
- nlistp
- null
- car
- cdr
- car-safe
- cdr-safe
- nth
- nthcdr
- length
- cons
- list
- make-list
- append
- reverse
- copy-tree
- number-sequence
- setcar
- setcdr
- symbol-value
- symbol-function
- set
- fset
- makunbound
- fmakunbound
- boundp
- fboundp
- apply
- funcall
- throw
- not
- eval
- load))
+ quote
+ %funcall
+ %set-lexical-binding-mode)
+ #:pure)
diff --git a/module/language/elisp/runtime/macros.scm b/module/language/elisp/runtime/macros.scm
deleted file mode 100644
index b28706781..000000000
--- a/module/language/elisp/runtime/macros.scm
+++ /dev/null
@@ -1,208 +0,0 @@
-;;; Guile Emacs Lisp
-
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
-;;;
-;;; This library is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU Lesser General Public
-;;; License as published by the Free Software Foundation; either
-;;; version 3 of the License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this library; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Code:
-
-(define-module (language elisp runtime macros)
- #:use-module (language elisp runtime))
-
-;;; This module contains the macro definitions of elisp symbols. In
-;;; contrast to the other runtime modules, those are used directly
-;;; during compilation, of course, so not really in runtime. But I
-;;; think it fits well to the others here.
-
-(built-in-macro lambda
- (lambda cdr
- `(function (lambda ,@cdr))))
-
-;;; The prog1 and prog2 constructs can easily be defined as macros using
-;;; progn and some lexical-let's to save the intermediate value to
-;;; return at the end.
-
-(built-in-macro prog1
- (lambda (form1 . rest)
- (let ((temp (gensym)))
- `(lexical-let ((,temp ,form1))
- ,@rest
- ,temp))))
-
-(built-in-macro prog2
- (lambda (form1 form2 . rest)
- `(progn ,form1 (prog1 ,form2 ,@rest))))
-
-;;; Define the conditionals when and unless as macros.
-
-(built-in-macro when
- (lambda (condition . thens)
- `(if ,condition (progn ,@thens) nil)))
-
-(built-in-macro unless
- (lambda (condition . elses)
- `(if ,condition nil (progn ,@elses))))
-
-;;; Impement the cond form as nested if's. A special case is a
-;;; (condition) subform, in which case we need to return the condition
-;;; itself if it is true and thus save it in a local variable before
-;;; testing it.
-
-(built-in-macro cond
- (lambda (. clauses)
- (let iterate ((tail clauses))
- (if (null? tail)
- 'nil
- (let ((cur (car tail))
- (rest (iterate (cdr tail))))
- (prim cond
- ((prim or (not (list? cur)) (null? cur))
- (macro-error "invalid clause in cond" cur))
- ((null? (cdr cur))
- (let ((var (gensym)))
- `(lexical-let ((,var ,(car cur)))
- (if ,var
- ,var
- ,rest))))
- (else
- `(if ,(car cur)
- (progn ,@(cdr cur))
- ,rest))))))))
-
-;;; The `and' and `or' forms can also be easily defined with macros.
-
-(built-in-macro and
- (case-lambda
- (() 't)
- ((x) x)
- ((x . args)
- (let iterate ((x x) (tail args))
- (if (null? tail)
- x
- `(if ,x
- ,(iterate (car tail) (cdr tail))
- nil))))))
-
-(built-in-macro or
- (case-lambda
- (() 'nil)
- ((x) x)
- ((x . args)
- (let iterate ((x x) (tail args))
- (if (null? tail)
- x
- (let ((var (gensym)))
- `(lexical-let ((,var ,x))
- (if ,var
- ,var
- ,(iterate (car tail) (cdr tail))))))))))
-
-;;; Define the dotimes and dolist iteration macros.
-
-(built-in-macro dotimes
- (lambda (args . body)
- (if (prim or
- (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dotimes arguments" args)
- (let ((var (car args))
- (count (cadr args)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dotimes variable"))
- `(let ((,var 0))
- (while ((guile-primitive <) ,var ,count)
- ,@body
- (setq ,var ((guile-primitive 1+) ,var)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '()))))))
-
-(built-in-macro dolist
- (lambda (args . body)
- (if (prim or
- (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dolist arguments" args)
- (let ((var (car args))
- (iter-list (cadr args))
- (tailvar (gensym)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dolist variable")
- `(let (,var)
- (lexical-let ((,tailvar ,iter-list))
- (while ((guile-primitive not)
- ((guile-primitive null?) ,tailvar))
- (setq ,var ((guile-primitive car) ,tailvar))
- ,@body
- (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '()))))))))
-
-;;; Exception handling. unwind-protect and catch are implemented as
-;;; macros (throw is a built-in function).
-
-;;; catch and throw can mainly be implemented directly using Guile's
-;;; primitives for exceptions, the only difficulty is that the keys used
-;;; within Guile must be symbols, while elisp allows any value and
-;;; checks for matches using eq (eq?). We handle this by using always #t
-;;; as key for the Guile primitives and check for matches inside the
-;;; handler; if the elisp keys are not eq?, we rethrow the exception.
-
-(built-in-macro catch
- (lambda (tag . body)
- (if (null? body)
- (macro-error "catch with empty body"))
- (let ((tagsym (gensym)))
- `(lexical-let ((,tagsym ,tag))
- ((guile-primitive catch)
- #t
- (lambda () ,@body)
- ,(let* ((dummy-key (gensym))
- (elisp-key (gensym))
- (value (gensym))
- (arglist `(,dummy-key ,elisp-key ,value)))
- `(with-always-lexical
- ,arglist
- (lambda ,arglist
- (if (eq ,elisp-key ,tagsym)
- ,value
- ((guile-primitive throw) ,dummy-key ,elisp-key
- ,value))))))))))
-
-;;; unwind-protect is just some weaker construct as dynamic-wind, so
-;;; straight-forward to implement.
-
-(built-in-macro unwind-protect
- (lambda (body . clean-ups)
- (if (null? clean-ups)
- (macro-error "unwind-protect without cleanup code"))
- `((guile-primitive dynamic-wind)
- (lambda () nil)
- (lambda () ,body)
- (lambda () ,@clean-ups))))
-
-;;; Pop off the first element from a list or push one to it.
-
-(built-in-macro pop
- (lambda (list-name)
- `(prog1 (car ,list-name)
- (setq ,list-name (cdr ,list-name)))))
-
-(built-in-macro push
- (lambda (new-el list-name)
- `(setq ,list-name (cons ,new-el ,list-name))))
diff --git a/module/language/elisp/runtime/subrs.scm b/module/language/elisp/runtime/subrs.scm
deleted file mode 100644
index b03a510a1..000000000
--- a/module/language/elisp/runtime/subrs.scm
+++ /dev/null
@@ -1,383 +0,0 @@
-;;; Guile Emacs Lisp
-
-;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;
-;;; This library is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU Lesser General Public License as
-;;; published by the Free Software Foundation; either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this library; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-;;; 02110-1301 USA
-
-;;; Code:
-
-(define-module (language elisp runtime subrs)
- #:use-module (language elisp runtime)
- #:use-module (system base compile))
-
-;;; This module contains the function-slots of elisp symbols. Elisp
-;;; built-in functions are implemented as predefined function bindings
-;;; here.
-
-;;; Equivalence and equalness predicates.
-
-(built-in-func eq
- (lambda (a b)
- (elisp-bool (eq? a b))))
-
-(built-in-func equal
- (lambda (a b)
- (elisp-bool (equal? a b))))
-
-;;; Number predicates.
-
-(built-in-func floatp
- (lambda (num)
- (elisp-bool (and (real? num)
- (or (inexact? num)
- (prim not (integer? num)))))))
-
-(built-in-func integerp
- (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)))))
-
-(built-in-func numberp
- (lambda (num)
- (elisp-bool (real? num))))
-
-(built-in-func wholenump
- (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)
- (prim >= num 0)))))
-
-(built-in-func zerop
- (lambda (num)
- (elisp-bool (prim = num 0))))
-
-;;; Number comparisons.
-
-(built-in-func =
- (lambda (num1 num2)
- (elisp-bool (prim = num1 num2))))
-
-(built-in-func /=
- (lambda (num1 num2)
- (elisp-bool (prim not (prim = num1 num2)))))
-
-(built-in-func <
- (lambda (num1 num2)
- (elisp-bool (prim < num1 num2))))
-
-(built-in-func <=
- (lambda (num1 num2)
- (elisp-bool (prim <= num1 num2))))
-
-(built-in-func >
- (lambda (num1 num2)
- (elisp-bool (prim > num1 num2))))
-
-(built-in-func >=
- (lambda (num1 num2)
- (elisp-bool (prim >= num1 num2))))
-
-(built-in-func max
- (lambda (. nums)
- (prim apply (@ (guile) max) nums)))
-
-(built-in-func min
- (lambda (. nums)
- (prim apply (@ (guile) min) nums)))
-
-(built-in-func abs
- (@ (guile) abs))
-
-;;; Number conversion.
-
-(built-in-func float
- (lambda (num)
- (if (exact? num)
- (exact->inexact num)
- num)))
-
-;;; TODO: truncate, floor, ceiling, round.
-
-;;; Arithmetic functions.
-
-(built-in-func 1+ (@ (guile) 1+))
-
-(built-in-func 1- (@ (guile) 1-))
-
-(built-in-func + (@ (guile) +))
-
-(built-in-func - (@ (guile) -))
-
-(built-in-func * (@ (guile) *))
-
-(built-in-func % (@ (guile) modulo))
-
-;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
-;;; values).
-
-;;; Floating-point rounding operations.
-
-(built-in-func ffloor (@ (guile) floor))
-
-(built-in-func fceiling (@ (guile) ceiling))
-
-(built-in-func ftruncate (@ (guile) truncate))
-
-(built-in-func fround (@ (guile) round))
-
-;;; List predicates.
-
-(built-in-func consp
- (lambda (el)
- (elisp-bool (pair? el))))
-
-(built-in-func atomp
- (lambda (el)
- (elisp-bool (prim not (pair? el)))))
-
-(built-in-func listp
- (lambda (el)
- (elisp-bool (or (pair? el) (null? el)))))
-
-(built-in-func nlistp
- (lambda (el)
- (elisp-bool (and (prim not (pair? el))
- (prim not (null? el))))))
-
-(built-in-func null
- (lambda (el)
- (elisp-bool (null? el))))
-
-;;; Accessing list elements.
-
-(built-in-func car
- (lambda (el)
- (if (null? el)
- nil-value
- (prim car el))))
-
-(built-in-func cdr
- (lambda (el)
- (if (null? el)
- nil-value
- (prim cdr el))))
-
-(built-in-func car-safe
- (lambda (el)
- (if (pair? el)
- (prim car el)
- nil-value)))
-
-(built-in-func cdr-safe
- (lambda (el)
- (if (pair? el)
- (prim cdr el)
- nil-value)))
-
-(built-in-func nth
- (lambda (n lst)
- (if (negative? n)
- (prim car lst)
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) (prim car tail))
- (else (iterate (prim 1- i) (prim cdr tail))))))))
-
-(built-in-func nthcdr
- (lambda (n lst)
- (if (negative? n)
- lst
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) tail)
- (else (iterate (prim 1- i) (prim cdr tail))))))))
-
-(built-in-func length (@ (guile) length))
-
-;;; Building lists.
-
-(built-in-func cons (@ (guile) cons))
-
-(built-in-func list (@ (guile) list))
-
-(built-in-func make-list
- (lambda (len obj)
- (prim make-list len obj)))
-
-(built-in-func append (@ (guile) append))
-
-(built-in-func reverse (@ (guile) reverse))
-
-(built-in-func copy-tree (@ (guile) copy-tree))
-
-(built-in-func number-sequence
- (lambda (from . rest)
- (if (prim > (prim length rest) 2)
- (runtime-error "too many arguments for number-sequence"
- (prim cdddr rest))
- (if (null? rest)
- `(,from)
- (let ((to (prim car rest))
- (sep (if (or (null? (prim cdr rest))
- (eq? nil-value (prim cadr rest)))
- 1
- (prim cadr rest))))
- (cond
- ((or (eq? nil-value to) (prim = to from)) `(,from))
- ((and (zero? sep) (prim not (prim = from to)))
- (runtime-error "infinite list in number-sequence"))
- ((prim < (prim * to sep) (prim * from sep)) '())
- (else
- (let iterate ((i (prim +
- from
- (prim *
- sep
- (prim quotient
- (prim abs
- (prim -
- to
- from))
- (prim abs sep)))))
- (result '()))
- (if (prim = i from)
- (prim cons i result)
- (iterate (prim - i sep)
- (prim cons i result)))))))))))
-
-;;; Changing lists.
-
-(built-in-func setcar
- (lambda (cell val)
- (if (and (null? cell) (null? val))
- #nil
- (prim set-car! cell val))
- val))
-
-(built-in-func setcdr
- (lambda (cell val)
- (if (and (null? cell) (null? val))
- #nil
- (prim set-cdr! cell val))
- val))
-
-;;; Accessing symbol bindings for symbols known only at runtime.
-
-(built-in-func symbol-value
- (lambda (sym)
- (reference-variable value-slot-module sym)))
-
-(built-in-func symbol-function
- (lambda (sym)
- (reference-variable function-slot-module sym)))
-
-(built-in-func set
- (lambda (sym value)
- (set-variable! value-slot-module sym value)))
-
-(built-in-func fset
- (lambda (sym value)
- (set-variable! function-slot-module sym value)))
-
-(built-in-func makunbound
- (lambda (sym)
- (if (module-bound? (resolve-interface value-slot-module) sym)
- (let ((var (module-variable (resolve-module value-slot-module)
- sym)))
- (if (and (variable-bound? var) (fluid? (variable-ref var)))
- (fluid-unset! (variable-ref var))
- (variable-unset! var))))
- sym))
-
-(built-in-func fmakunbound
- (lambda (sym)
- (if (module-bound? (resolve-interface function-slot-module) sym)
- (let ((var (module-variable
- (resolve-module function-slot-module)
- sym)))
- (if (and (variable-bound? var) (fluid? (variable-ref var)))
- (fluid-unset! (variable-ref var))
- (variable-unset! var))))
- sym))
-
-(built-in-func boundp
- (lambda (sym)
- (elisp-bool
- (and
- (module-bound? (resolve-interface value-slot-module) sym)
- (let ((var (module-variable (resolve-module value-slot-module)
- sym)))
- (and (variable-bound? var)
- (if (fluid? (variable-ref var))
- (fluid-bound? (variable-ref var))
- #t)))))))
-
-(built-in-func fboundp
- (lambda (sym)
- (elisp-bool
- (and
- (module-bound? (resolve-interface function-slot-module) sym)
- (let* ((var (module-variable (resolve-module function-slot-module)
- sym)))
- (and (variable-bound? var)
- (if (fluid? (variable-ref var))
- (fluid-bound? (variable-ref var))
- #t)))))))
-
-;;; Function calls. These must take care of special cases, like using
-;;; symbols or raw lambda-lists as functions!
-
-(built-in-func apply
- (lambda (func . args)
- (let ((real-func (cond
- ((symbol? func)
- (reference-variable function-slot-module func))
- ((list? func)
- (if (and (prim not (null? func))
- (eq? (prim car func) 'lambda))
- (compile func #:from 'elisp #:to 'value)
- (runtime-error "list is not a function"
- func)))
- (else func))))
- (prim apply (@ (guile) apply) real-func args))))
-
-(built-in-func funcall
- (lambda (func . args)
- (apply func args)))
-
-;;; Throw can be implemented as built-in function.
-
-(built-in-func throw
- (lambda (tag value)
- (prim throw 'elisp-exception tag value)))
-
-;;; Miscellaneous.
-
-(built-in-func not
- (lambda (x)
- (if x nil-value t-value)))
-
-(built-in-func eval
- (lambda (form)
- (compile form #:from 'elisp #:to 'value)))
-
-(built-in-func load
- (lambda* (file)
- (compile-file file #:from 'elisp #:to 'value)
- #t))
diff --git a/module/language/elisp/runtime/value-slot.scm b/module/language/elisp/runtime/value-slot.scm
index c6cc3b46f..c2f3666cc 100644
--- a/module/language/elisp/runtime/value-slot.scm
+++ b/module/language/elisp/runtime/value-slot.scm
@@ -18,6 +18,7 @@
;;; Code:
-(define-module (language elisp runtime value-slot))
+(define-module (language elisp runtime value-slot)
+ #:pure)
;;; This module contains the value-slots of elisp symbols.
diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm
index 3da368093..38a32c2df 100644
--- a/module/language/elisp/spec.scm
+++ b/module/language/elisp/spec.scm
@@ -22,6 +22,7 @@
#:use-module (language elisp compile-tree-il)
#:use-module (language elisp parser)
#:use-module (system base language)
+ #:use-module (system base compile)
#:export (elisp))
(define-language elisp
@@ -29,3 +30,6 @@
#:reader (lambda (port env) (read-elisp port))
#:printer write
#:compilers `((tree-il . ,compile-tree-il)))
+
+(compile-and-load (%search-load-path "language/elisp/boot.el")
+ #:from 'elisp)
diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm
new file mode 100644
index 000000000..9654c0861
--- /dev/null
+++ b/module/language/objcode/elf.scm
@@ -0,0 +1,94 @@
+;;; Embedding bytecode in ELF
+
+;; Copyright (C) 2012 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+;; The eval-when is because (language objcode elf) will not be loaded
+;; yet when we go to compile it, but later passes of the
+;; compiler need it. So we have to be sure that the module is present
+;; at compile time, with all of its definitions. The easiest way to do
+;; that is just to go ahead and resolve it now.
+;;
+(define-module (language objcode elf)
+ #:use-module (system vm objcode)
+ #:use-module (system base target)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (system vm elf)
+ #:export (write-objcode))
+
+(define (bytecode->elf bv)
+ (let ((string-table (make-elf-string-table)))
+ (define (intern-string! string)
+ (call-with-values
+ (lambda () (elf-string-table-intern string-table string))
+ (lambda (table idx)
+ (set! string-table table)
+ idx)))
+ (define (make-object name bv relocs . kwargs)
+ (let ((name-idx (intern-string! (symbol->string name))))
+ (make-elf-object (apply make-elf-section
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (list (make-elf-symbol name 0)))))
+ (define (make-dynamic-section word-size endianness)
+ (define (make-dynamic-section/32)
+ (let ((bv (make-bytevector 24 0)))
+ (bytevector-u32-set! bv 0 DT_GUILE_RTL_VERSION endianness)
+ (bytevector-u32-set! bv 4 #x02000000 endianness)
+ (bytevector-u32-set! bv 8 DT_GUILE_ENTRY endianness)
+ (bytevector-u32-set! bv 12 0 endianness)
+ (bytevector-u32-set! bv 16 DT_NULL endianness)
+ (bytevector-u32-set! bv 20 0 endianness)
+ (values bv (make-elf-reloc 'abs32/1 12 0 '.rtl-text))))
+ (define (make-dynamic-section/64)
+ (let ((bv (make-bytevector 48 0)))
+ (bytevector-u64-set! bv 0 DT_GUILE_RTL_VERSION endianness)
+ (bytevector-u64-set! bv 8 #x02000000 endianness)
+ (bytevector-u64-set! bv 16 DT_GUILE_ENTRY endianness)
+ (bytevector-u64-set! bv 24 0 endianness)
+ (bytevector-u64-set! bv 32 DT_NULL endianness)
+ (bytevector-u64-set! bv 40 0 endianness)
+ (values bv (make-elf-reloc 'abs64/1 24 0 '.rtl-text))))
+ (call-with-values (lambda ()
+ (case word-size
+ ((4) (make-dynamic-section/32))
+ ((8) (make-dynamic-section/64))
+ (else (error "unexpected word size" word-size))))
+ (lambda (bv reloc)
+ (make-object '.dynamic bv (list reloc)
+ #:type SHT_DYNAMIC #:flags SHF_ALLOC))))
+ (define (link-string-table)
+ (intern-string! ".shstrtab")
+ (make-object '.shstrtab (link-elf-string-table string-table) '()
+ #:type SHT_STRTAB #:flags 0))
+ (let* ((word-size (target-word-size))
+ (endianness (target-endianness))
+ (text (make-object '.rtl-text bv '()))
+ (dt (make-dynamic-section word-size endianness))
+ ;; This needs to be linked last, because linking other
+ ;; sections adds entries to the string table.
+ (shstrtab (link-string-table)))
+ (link-elf (list text dt shstrtab)
+ #:endianness endianness #:word-size word-size))))
+
+(define (write-objcode objcode port)
+ (let ((bv (objcode->bytecode objcode (target-endianness))))
+ (put-bytevector port (bytecode->elf bv))))
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index bf0649a54..16f52410a 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -22,6 +22,7 @@
#:use-module (system base language)
#:use-module (system vm objcode)
#:use-module (system vm program)
+ #:use-module (language objcode elf)
#:export (objcode))
(define (objcode->value x e opts)
diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
index f94661da4..c065474b5 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -219,10 +219,12 @@
exp
`(quote ,exp)))
- ((<sequence> exps)
- (build-begin (map recurse exps)))
+ ((<seq> head tail)
+ (build-begin (cons (recurse head)
+ (build-begin-body
+ (recurse tail)))))
- ((<application> proc args)
+ ((<call> proc args)
(match `(,(recurse proc) ,@(map recurse args))
((('lambda (formals ...) body ...) args ...)
(=> failure)
@@ -231,6 +233,9 @@
(failure)))
(e e)))
+ ((<primcall> name args)
+ `(,name ,@(map recurse args)))
+
((<primitive-ref> name)
name)
@@ -658,7 +663,7 @@
((<void>) (primitive 'if)) ; (if #f #f)
((<const>) (primitive 'quote))
- ((<application> proc args)
+ ((<call> proc args)
(if (lexical-ref? proc)
(let* ((gensym (lexical-ref-gensym proc))
(name (source-name gensym)))
@@ -673,6 +678,7 @@
(for-each recurse args))
((<primitive-ref> name) (primitive name))
+ ((<primcall> name args) (primitive name) (for-each recurse args))
((<lexical-ref> gensym) (lexical gensym))
((<lexical-set> gensym exp)
@@ -695,7 +701,9 @@
(primitive 'if)
(recurse test) (recurse consequent) (recurse alternate))
- ((<sequence> exps) (primitive 'begin) (for-each recurse exps))
+ ((<seq> head tail)
+ (primitive 'begin) (recurse head) (recurse tail))
+
((<lambda> body)
(if body (recurse body)))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index aa00b381e..ddcba9938 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -34,8 +34,9 @@
<toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
<toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
- <application> application? make-application application-src application-proc application-args
- <sequence> sequence? make-sequence sequence-src sequence-exps
+ <call> call? make-call call-src call-proc call-args
+ <primcall> primcall? make-primcall primcall-src primcall-name primcall-args
+ <seq> seq? make-seq seq-src seq-head seq-tail
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
@@ -45,13 +46,15 @@
<letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
- <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
+ <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-pre dynwind-body dynwind-post dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
<dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
+ list->seq
+
parse-tree-il
unparse-tree-il
tree-il->scheme
@@ -121,8 +124,9 @@
;; (<toplevel-set> name exp)
;; (<toplevel-define> name exp)
;; (<conditional> test consequent alternate)
- ;; (<application> proc args)
- ;; (<sequence> exps)
+ ;; (<call> proc args)
+ ;; (<primcall> name args)
+ ;; (<seq> head tail)
;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
;; (<let> names gensyms vals body)
@@ -132,7 +136,7 @@
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
- (<dynwind> winder body unwinder)
+ (<dynwind> winder pre body post unwinder)
(<dynref> fluid)
(<dynset> fluid exp)
(<prompt> tag body handler)
@@ -140,6 +144,14 @@
+;; A helper.
+(define (list->seq loc exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq loc (car exps) (list->seq #f (cdr exps)))))
+
+
+
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
@@ -152,8 +164,11 @@
((void)
(make-void loc))
- ((apply ,proc . ,args)
- (make-application loc (retrans proc) (map retrans args)))
+ ((call ,proc . ,args)
+ (make-call loc (retrans proc) (map retrans args)))
+
+ ((primcall ,name . ,args)
+ (make-primcall loc name (map retrans args)))
((if ,test ,consequent ,alternate)
(make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
@@ -212,8 +227,12 @@
((const ,exp)
(make-const loc exp))
+ ((seq ,head ,tail)
+ (make-seq loc (retrans head) (retrans tail)))
+
+ ;; Convenience.
((begin . ,exps)
- (make-sequence loc (map retrans exps)))
+ (list->seq loc (map retrans exps)))
((let ,names ,gensyms ,vals ,body)
(make-let loc names gensyms (map retrans vals) (retrans body)))
@@ -230,8 +249,10 @@
((let-values ,exp ,body)
(make-let-values loc (retrans exp) (retrans body)))
- ((dynwind ,winder ,body ,unwinder)
- (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
+ ((dynwind ,winder ,pre ,body ,post ,unwinder)
+ (make-dynwind loc (retrans winder) (retrans pre)
+ (retrans body)
+ (retrans post) (retrans unwinder)))
((dynlet ,fluids ,vals ,body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
@@ -256,8 +277,11 @@
((<void>)
'(void))
- ((<application> proc args)
- `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+ ((<call> proc args)
+ `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+
+ ((<primcall> name args)
+ `(primcall ,name ,@(map unparse-tree-il args)))
((<conditional> test consequent alternate)
`(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
@@ -299,9 +323,9 @@
((<const> exp)
`(const ,exp))
- ((<sequence> exps)
- `(begin ,@(map unparse-tree-il exps)))
-
+ ((<seq> head tail)
+ `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
+
((<let> names gensyms vals body)
`(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
@@ -315,9 +339,10 @@
((<let-values> exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- ((<dynwind> winder body unwinder)
- `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
- ,(unparse-tree-il unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
+ ,(unparse-tree-il body)
+ ,(unparse-tree-il post) ,(unparse-tree-il unwinder)))
((<dynlet> fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
@@ -349,7 +374,7 @@ invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
and SEED is the current result, intially seeded with SEED.
This is an implementation of `foldts' as described by Andy Wingo in
-``Applications of fold to XML transformation''."
+``Calls of fold to XML transformation''."
(let loop ((tree tree)
(result seed))
(if (or (null? tree) (pair? tree))
@@ -367,10 +392,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop alternate
(loop consequent
(loop test (down tree result))))))
- ((<application> proc args)
+ ((<call> proc args)
(up tree (loop (cons proc args) (down tree result))))
- ((<sequence> exps)
- (up tree (loop exps (down tree result))))
+ ((<primcall> name args)
+ (up tree (loop args (down tree result))))
+ ((<seq> head tail)
+ (up tree (loop tail (loop head (down tree result)))))
((<lambda> body)
(let ((result (down tree result)))
(up tree
@@ -396,10 +423,13 @@ This is an implementation of `foldts' as described by Andy Wingo in
(down tree result)))))
((<let-values> exp body)
(up tree (loop body (loop exp (down tree result)))))
- ((<dynwind> body winder unwinder)
+ ((<dynwind> winder pre body post unwinder)
(up tree (loop unwinder
- (loop winder
- (loop body (down tree result))))))
+ (loop post
+ (loop body
+ (loop pre
+ (loop winder
+ (down tree result))))))))
((<dynlet> fluids vals body)
(up tree (loop body
(loop vals
@@ -442,11 +472,14 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
- ((<application> proc args)
+ ((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
- ((<sequence> exps)
- (fold-values foldts exps seed ...))
+ ((<primcall> name args)
+ (fold-values foldts args seed ...))
+ ((<seq> head tail)
+ (let-values (((seed ...) (foldts head seed ...)))
+ (foldts tail seed ...)))
((<lambda> body)
(if body
(foldts body seed ...)
@@ -469,9 +502,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- ((<dynwind> body winder unwinder)
- (let*-values (((seed ...) (foldts body seed ...))
- ((seed ...) (foldts winder seed ...)))
+ ((<dynwind> winder pre body post unwinder)
+ (let*-values (((seed ...) (foldts winder seed ...))
+ ((seed ...) (foldts pre seed ...))
+ ((seed ...) (foldts body seed ...))
+ ((seed ...) (foldts post seed ...)))
(foldts unwinder seed ...)))
((<dynlet> fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
@@ -497,9 +532,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
(define (post-order! f x)
(let lp ((x x))
(record-case x
- ((<application> proc args)
- (set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args)))
+ ((<call> proc args)
+ (set! (call-proc x) (lp proc))
+ (set! (call-args x) (map lp args)))
+
+ ((<primcall> name args)
+ (set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
@@ -528,9 +566,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(if alternate
(set! (lambda-case-alternate x) (lp alternate))))
- ((<sequence> exps)
- (set! (sequence-exps x) (map lp exps)))
-
+ ((<seq> head tail)
+ (set! (seq-head x) (lp head))
+ (set! (seq-tail x) (lp tail)))
+
((<let> gensyms vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
@@ -547,9 +586,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
@@ -582,9 +623,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let lp ((x x))
(let ((x (or (f x) x)))
(record-case x
- ((<application> proc args)
- (set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args)))
+ ((<call> proc args)
+ (set! (call-proc x) (lp proc))
+ (set! (call-args x) (map lp args)))
+
+ ((<primcall> name args)
+ (set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
@@ -612,9 +656,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (lambda-case-body x) (lp body))
(if alternate (set! (lambda-case-alternate x) (lp alternate))))
- ((<sequence> exps)
- (set! (sequence-exps x) (map lp exps)))
-
+ ((<seq> head tail)
+ (set! (seq-head x) (lp head))
+ (set! (seq-tail x) (lp tail)))
+
((<let> vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
@@ -631,9 +676,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index badce9f77..f5890b25a 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -180,10 +180,13 @@
(analyze! x new-proc (append labels labels-in-proc) #t #f))
(define (recur x new-proc) (analyze! x new-proc '() tail? #f))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply lset-union eq? (step-tail-call proc args)
(map step args)))
+ ((<primcall> args)
+ (apply lset-union eq? (map step args)))
+
((<conditional> test consequent alternate)
(lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
@@ -222,13 +225,8 @@
((<toplevel-define> exp)
(step exp))
- ((<sequence> exps)
- (let lp ((exps exps) (ret '()))
- (cond ((null? exps) '())
- ((null? (cdr exps))
- (lset-union eq? ret (step-tail (car exps))))
- (else
- (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
+ ((<seq> head tail)
+ (lset-union eq? (step head) (step-tail tail)))
((<lambda> body)
;; order is important here
@@ -339,8 +337,10 @@
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynwind> body winder unwinder)
- (lset-union eq? (step body) (step winder) (step unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (lset-union eq? (step winder) (step pre)
+ (step body)
+ (step post) (step unwinder)))
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
@@ -367,9 +367,12 @@
(define (allocate! x proc n)
(define (recur y) (allocate! y proc n))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply max (recur proc) (map recur args)))
+ ((<primcall> args)
+ (apply max n (map recur args)))
+
((<conditional> test consequent alternate)
(max (recur test) (recur consequent) (recur alternate)))
@@ -385,8 +388,9 @@
((<toplevel-define> exp)
(recur exp))
- ((<sequence> exps)
- (apply max (map recur exps)))
+ ((<seq> head tail)
+ (max (recur head)
+ (recur tail)))
((<lambda> body)
;; allocate closure vars in order
@@ -509,8 +513,10 @@
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynwind> body winder unwinder)
- (max (recur body) (recur winder) (recur unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (max (recur winder) (recur pre)
+ (recur body)
+ (recur post) (recur unwinder)))
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
@@ -866,7 +872,7 @@ accurate information is missing from a given `tree-il' element."
(defs toplevel-info-defs)) ;; (VARIABLE-NAME ...)
(define (goops-toplevel-definition proc args env)
- ;; If application of PROC to ARGS is a GOOPS top-level definition, return
+ ;; If call of PROC to ARGS is a GOOPS top-level definition, return
;; the name of the variable being defined; otherwise return #f. This
;; assumes knowledge of the current implementation of `define-class' et al.
(define (toplevel-define-arg args)
@@ -927,7 +933,7 @@ accurate information is missing from a given `tree-il' element."
(make-toplevel-info (vhash-delq name refs)
(vhash-consq name #t defs)))
- ((<application> proc args)
+ ((<call> proc args)
;; Check for a dynamic top-level definition, as is
;; done by code expanded from GOOPS macros.
(let ((name (goops-toplevel-definition proc args
@@ -965,12 +971,12 @@ accurate information is missing from a given `tree-il' element."
(define-record-type <arity-info>
(make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
arity-info?
- (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
+ (toplevel-calls toplevel-procedure-calls) ;; ((NAME . CALL) ...)
(lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
(toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
-(define (validate-arity proc application lexical?)
- ;; Validate the argument count of APPLICATION, a tree-il application of
+(define (validate-arity proc call lexical?)
+ ;; Validate the argument count of CALL, a tree-il call of
;; PROC, emitting a warning in case of argument count mismatch.
(define (filter-keyword-args keywords allow-other-keys? args)
@@ -1034,8 +1040,8 @@ accurate information is missing from a given `tree-il' element."
(else
(values #f #f))))))))
- (let ((args (application-args application))
- (src (tree-il-src application)))
+ (let ((args (call-args call))
+ (src (tree-il-src call)))
(call-with-values (lambda () (arities proc))
(lambda (name arities)
(define matches?
@@ -1122,7 +1128,7 @@ accurate information is missing from a given `tree-il' element."
((<fix> gensyms vals)
(fold extend info gensyms vals))
- ((<application> proc args src)
+ ((<call> proc args src)
(record-case proc
((<lambda> body)
(validate-arity proc x #t)
@@ -1182,9 +1188,9 @@ accurate information is missing from a given `tree-il' element."
(let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result)))
(vlist-for-each
- (lambda (name+application)
- (let* ((name (car name+application))
- (application (cdr name+application))
+ (lambda (name+call)
+ (let* ((name (car name+call))
+ (call (cdr name+call))
(proc
(or (and=> (vhash-assq name toplevel-lambdas) cdr)
(and (module? env)
@@ -1199,9 +1205,9 @@ accurate information is missing from a given `tree-il' element."
(module-ref env name))))
proc)))
(cond ((lambda? proc*)
- (validate-arity proc* application #t))
+ (validate-arity proc* call #t))
((procedure? proc*)
- (validate-arity proc* application #f)))))
+ (validate-arity proc* call #f)))))
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
@@ -1395,11 +1401,11 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
(match x
(($ <const> _ (? string? exp))
exp)
- (($ <application> _ (? (cut gettext? <> env))
+ (($ <call> _ (? (cut gettext? <> env))
(($ <const> _ (? string? fmt))))
;; Gettexted literals, like `(_ "foo")'.
fmt)
- (($ <application> _ (? (cut ngettext? <> env))
+ (($ <call> _ (? (cut ngettext? <> env))
(($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1))
;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.
@@ -1490,17 +1496,17 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
(false-if-exception (module-ref env name))))
(match x
- (($ <application> src ($ <toplevel-ref> _ name) args)
+ (($ <call> src ($ <toplevel-ref> _ name) args)
(let ((proc (resolve-toplevel name)))
(if (or (and (eq? proc (@ (guile) simple-format))
(check-simple-format-args args
(or src (find pair? locs))))
(eq? proc (@ (ice-9 format) format)))
(check-format-args args (or src (find pair? locs))))))
- (($ <application> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+ (($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args)
(check-format-args args (or src (find pair? locs))))
- (($ <application> src ($ <module-ref> _ '(guile)
- (or 'format 'simple-format))
+ (($ <call> src ($ <module-ref> _ '(guile)
+ (or 'format 'simple-format))
args)
(and (check-simple-format-args args
(or src (find pair? locs)))
diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
index 2fa8c2ec9..1db842022 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -36,16 +36,6 @@
(post-order!
(lambda (x)
(match x
- (($ <sequence> src (tail))
- tail)
- (($ <sequence> src exps)
- (and (any sequence? exps)
- (make-sequence src
- (append-map (lambda (x)
- (if (sequence? x)
- (sequence-exps x)
- (list x)))
- exps))))
(($ <let> src () () () body)
body)
(($ <letrec> src _ () () () body)
@@ -60,9 +50,9 @@
src meta
(make-lambda-case
#f '() #f #f #f '() '()
- (make-application
+ (make-primcall
#f
- (make-primitive-ref #f 'throw)
+ 'throw
(list (make-const #f 'wrong-number-of-args)
(make-const #f #f)
(make-const #f "Wrong number of arguments")
@@ -80,7 +70,7 @@
(else #f)))
(define (thunk-application? x)
(match x
- (($ <application> _
+ (($ <call> _
($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
()) #t)
(_ #f)))
@@ -88,7 +78,7 @@
(define thunk
(make-lambda #f '()
(make-lambda-case #f '() #f #f #f '() '() body #f)))
- (make-application #f thunk '()))
+ (make-call #f thunk '()))
;; This code has a nasty job to do: to ensure that either the
;; handler is escape-only, or the body is the application of a
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index e4df6e1bd..1b6fea69c 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -110,11 +110,15 @@
((list? . 1) . list?)
((symbol? . 1) . symbol?)
((vector? . 1) . vector?)
+ ((nil? . 1) . nil?)
(list . list)
(vector . vector)
((class-of . 1) . class-of)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
+ ((string-length . 1) . string-length)
+ ((string-ref . 2) . string-ref)
+ ((vector-length . 1) . vector-length)
((vector-ref . 2) . vector-ref)
((vector-set! . 3) . vector-set)
((variable-ref . 1) . variable-ref)
@@ -268,199 +272,12 @@
(emit-code src (make-glil-const exp))))
(maybe-emit-return))
- ;; FIXME: should represent sequence as exps tail
- ((<sequence> exps)
- (let lp ((exps exps))
- (if (null? (cdr exps))
- (comp-tail (car exps))
- (begin
- (comp-drop (car exps))
- (lp (cdr exps))))))
-
- ((<application> src proc args)
- ;; FIXME: need a better pattern-matcher here
+ ((<seq> head tail)
+ (comp-drop head)
+ (comp-tail tail))
+
+ ((<call> src proc args)
(cond
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@apply)
- (>= (length args) 1))
- (let ((proc (car args))
- (args (cdr args)))
- (cond
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)) (not (eq? context 'vals)))
- ;; tail: (lambda () (apply values '(1 2)))
- ;; drop: (lambda () (apply values '(1 2)) 3)
- ;; push: (lambda () (list (apply values '(10 12)) 1))
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values* (length args))))))
-
- (else
- (case context
- ((tail)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
- ((push)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args))))
- (maybe-emit-return))
- ((vals)
- (comp-vals
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args))
- MVRA)
- (maybe-emit-return))
- ((drop)
- ;; Well, shit. The proc might return any number of
- ;; values (including 0), since it's in a drop context,
- ;; yet apply does not create a MV continuation. So we
- ;; mv-call out to our trampoline instead.
- (comp-drop
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values))
- ;; tail: (lambda () (values '(1 2)))
- ;; drop: (lambda () (values '(1 2)) 3)
- ;; push: (lambda () (list (values '(10 12)) 1))
- ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((push)
- (case (length args)
- ((0)
- ;; FIXME: This is surely an error. We need to add a
- ;; values-mismatch warning pass.
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (emit-code src (make-glil-call 'call 0))
- (maybe-emit-return))
- (else
- ;; Taking advantage of unspecified order of evaluation of
- ;; arguments.
- (for-each comp-drop (cdr args))
- (comp-push (car args))
- (maybe-emit-return))))
- ((vals)
- (for-each comp-push args)
- (emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br MVRA))
- ((tail)
- (for-each comp-push args)
- (emit-code src (let ((len (length args)))
- (if (= len 1)
- (make-glil-call 'return 1)
- (make-glil-call 'return/values len)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2))
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (case context
- ((vals)
- ;; Fall back.
- (comp-vals
- (make-application src (make-primitive-ref #f 'call-with-values)
- args)
- MVRA)
- (maybe-emit-return))
- (else
- (let ((MV (make-label)) (POST (make-label))
- (producer (car args)) (consumer (cadr args)))
- (if (not (eq? context 'tail))
- (emit-code src (make-glil-call 'new-frame 0)))
- (comp-push consumer)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-current-continuation)
- (= (length args) 1))
- (case context
- ((tail)
- (comp-push (car args))
- (emit-code src (make-glil-call 'tail-call/cc 1)))
- ((vals)
- (comp-vals
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args)
- MVRA)
- (maybe-emit-return))
- ((push)
- (comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1))
- (maybe-emit-return))
- ((drop)
- ;; Crap. Just like `apply' in drop context.
- (comp-drop
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args))
- (maybe-emit-return))))
-
- ;; A hack for variable-set, the opcode for which takes its args
- ;; reversed, relative to the variable-set! function
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) 'variable-set!)
- (= (length args) 2))
- (comp-push (cadr args))
- (comp-push (car args))
- (emit-code src (make-glil-call 'variable-set 2))
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((and (primitive-ref? proc)
- (or (hash-ref *primcall-ops*
- (cons (primitive-ref-name proc) (length args)))
- (hash-ref *primcall-ops* (primitive-ref-name proc))))
- => (lambda (op)
- (for-each comp-push args)
- (emit-code src (make-glil-call op (length args)))
- (case (instruction-pushes op)
- ((0)
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
- ((1)
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
- ((-1)
- ;; A control instruction, like return/values. Here we
- ;; just have to hope that the author of the tree-il
- ;; knew what they were doing.
- *unspecified*)
- (else
- (error "bad primitive op: too many pushes"
- op (instruction-pushes op))))))
-
;; call to the same lambda-case in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
@@ -553,6 +370,157 @@
(emit-branch #f 'br RA)
(emit-label POST)))))))))
+ ((<primcall> src name args)
+ (pmatch (cons name args)
+ ((@apply ,proc . ,args)
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)) (not (eq? context 'vals)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+ ((push)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args))))
+ (maybe-emit-return))
+ (else
+ (comp-tail (make-primcall src 'apply (cons proc args))))))))
+
+ ((values . _)
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((push)
+ (case (length args)
+ ((0)
+ ;; FIXME: This is surely an error. We need to add a
+ ;; values-mismatch warning pass.
+ (comp-push (make-call src (make-primitive-ref #f 'values)
+ '())))
+ (else
+ ;; Taking advantage of unspecified order of evaluation of
+ ;; arguments.
+ (for-each comp-drop (cdr args))
+ (comp-push (car args))
+ (maybe-emit-return))))
+ ((vals)
+ (for-each comp-push args)
+ (emit-code #f (make-glil-const (length args)))
+ (emit-branch src 'br MVRA))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (let ((len (length args)))
+ (if (= len 1)
+ (make-glil-call 'return 1)
+ (make-glil-call 'return/values len)))))))
+
+ ((@call-with-values ,producer ,consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (case context
+ ((vals)
+ ;; Fall back.
+ (comp-tail (make-primcall src 'call-with-values args)))
+ (else
+ (let ((MV (make-label)) (POST (make-label)))
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
+ (comp-push consumer)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
+
+ ((@call-with-current-continuation ,proc)
+ (case context
+ ((tail)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'tail-call/cc 1)))
+ ((vals)
+ (comp-vals
+ (make-primcall src 'call-with-current-continuation args)
+ MVRA)
+ (maybe-emit-return))
+ ((push)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
+ ((drop)
+ ;; Fall back.
+ (comp-tail
+ (make-primcall src 'call-with-current-continuation args)))))
+
+ ;; A hack for variable-set, the opcode for which takes its args
+ ;; reversed, relative to the variable-set! function
+ ((variable-set! ,var ,val)
+ (comp-push val)
+ (comp-push var)
+ (emit-code src (make-glil-call 'variable-set 2))
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ (else
+ (cond
+ ((or (hash-ref *primcall-ops* (cons name (length args)))
+ (hash-ref *primcall-ops* name))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case (instruction-pushes op)
+ ((0)
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+ ((1)
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+ ((-1)
+ ;; A control instruction, like return/values. Here we
+ ;; just have to hope that the author of the tree-il
+ ;; knew what they were doing.
+ *unspecified*)
+ (else
+ (error "bad primitive op: too many pushes"
+ op (instruction-pushes op))))))
+ (else
+ ;; Fall back to the normal compilation strategy.
+ (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
+
((<conditional> src test consequent alternate)
;; TEST
;; (br-if-not L1)
@@ -561,54 +529,39 @@
;; L1: alternate
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
- ;; need a pattern matcher
(record-case test
- ((<application> proc args)
- (record-case proc
- ((<primitive-ref> name)
- (let ((len (length args)))
- (cond
-
- ((and (eq? name 'eq?) (= len 2))
- (comp-push (car args))
- (comp-push (cadr args))
- (emit-branch src 'br-if-not-eq L1))
-
- ((and (eq? name 'null?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-not-null L1))
-
- ((and (eq? name 'not) (= len 1))
- (let ((app (car args)))
- (record-case app
- ((<application> proc args)
- (let ((len (length args)))
- (record-case proc
- ((<primitive-ref> name)
- (cond
-
- ((and (eq? name 'eq?) (= len 2))
- (comp-push (car args))
- (comp-push (cadr args))
- (emit-branch src 'br-if-eq L1))
-
- ((and (eq? name 'null?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-null L1))
-
- (else
- (comp-push app)
- (emit-branch src 'br-if L1))))
- (else
- (comp-push app)
- (emit-branch src 'br-if L1)))))
- (else
- (comp-push app)
- (emit-branch src 'br-if L1)))))
-
- (else
- (comp-push test)
- (emit-branch src 'br-if-not L1)))))
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-not-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-not-null L1))
+ ((nil? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-not-nil L1))
+ ((not ,x)
+ (record-case x
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-null L1))
+ ((nil? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-nil L1))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
(else
(comp-push test)
(emit-branch src 'br-if-not L1))))
@@ -985,10 +938,34 @@
;; to have body's return value(s) on the stack while the unwinder runs,
;; then proceed with returning or dropping or what-have-you, interacting
;; with RA and MVRA. What have you, I say.
- ((<dynwind> src body winder unwinder)
+ ((<dynwind> src winder pre body post unwinder)
+ (define (thunk? x)
+ (and (lambda? x)
+ (null? (lambda-case-gensyms (lambda-body x)))))
+ (define (make-wrong-type-arg x)
+ (make-primcall src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "dynamic-wind")
+ (make-const #f "Wrong type (expecting thunk): ~S")
+ (make-primcall #f 'list (list x))
+ (make-primcall #f 'list (list x)))))
+ (define (emit-thunk-check x)
+ (comp-drop (make-conditional
+ src
+ (make-primcall src 'thunk? (list x))
+ (make-void #f)
+ (make-wrong-type-arg x))))
+
+ ;; We know at this point that `winder' and `unwinder' are
+ ;; constant expressions and can be duplicated.
+ (if (not (thunk? winder))
+ (emit-thunk-check winder))
(comp-push winder)
+ (if (not (thunk? unwinder))
+ (emit-thunk-check unwinder))
(comp-push unwinder)
- (comp-drop (make-application src winder '()))
+ (comp-drop pre)
(emit-code #f (make-glil-call 'wind 2))
(case context
@@ -997,14 +974,14 @@
(comp-vals body MV)
;; one value: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; ...and return the val
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1))))
@@ -1013,7 +990,7 @@
(comp-push body)
;; and unwind, leaving the val on the stack
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '())))
+ (comp-drop post))
((vals)
(let ((MV (make-label)))
@@ -1024,7 +1001,7 @@
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and goto the MVRA.
(emit-branch #f 'br MVRA)))
@@ -1032,7 +1009,7 @@
;; compile body, discarding values. then unwind...
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and fall through, or goto RA if there is one.
(if RA
(emit-branch #f 'br RA)))))
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index b025bcb08..f8df3ce55 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -149,8 +149,7 @@
(define (boolean-valued-expression? x ctx)
(match x
- (($ <application> _
- ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
+ (($ <primcall> _ (? boolean-valued-primitive?)) #t)
(($ <const> _ (? boolean?)) #t)
(_ (eq? ctx 'test))))
@@ -163,9 +162,8 @@
(($ <primitive-ref>) #t)
(($ <module-ref>) #t)
(($ <toplevel-ref>) #t)
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (($ <primcall> _ (? singly-valued-primitive?)) #t)
+ (($ <primcall> _ 'values (val)) #t)
(($ <lambda>) #t)
(_ (eq? ctx 'value))))
@@ -188,17 +186,13 @@
(make-const src #f))
(($ <conditional> src test consequent alternate)
(make-conditional src test (negate consequent ctx) (negate alternate ctx)))
- (($ <application> _ ($ <primitive-ref> _ 'not)
+ (($ <primcall> _ 'not
((and x (? (cut boolean-valued-expression? <> ctx)))))
x)
- (($ <application> src
- ($ <primitive-ref> _ (and pred (? negate-primitive)))
- args)
- (make-application src
- (make-primitive-ref #f (negate-primitive pred))
- args))
+ (($ <primcall> src (and pred (? negate-primitive)) args)
+ (make-primcall src (negate-primitive pred) args))
(_
- (make-application #f (make-primitive-ref #f 'not) (list exp)))))
+ (make-primcall #f 'not (list exp)))))
(define (hasher n)
@@ -267,7 +261,7 @@
exp
(make-const src (not (not val)))))
;; For (not FOO), try to prove FOO, then negate the result.
- (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
+ (($ <primcall> src 'not (exp*))
(match (find-dominating-test exp* effects db)
(($ <const> _ val)
(log 'inferring exp (not val))
@@ -450,12 +444,19 @@
((consumer db**) (visit consumer (concat db* db) env ctx)))
(return (make-let-values src producer consumer)
(concat db** db*))))
- (($ <dynwind> src winder body unwinder)
- (let*-values (((pre db*) (visit winder db env 'value))
- ((body db**) (visit body (concat db* db) env ctx))
- ((post db***) (visit unwinder db env 'value)))
- (return (make-dynwind src pre body post)
- (concat db* (concat db** db***)))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (let*-values (((winder db*) (visit winder db env 'value))
+ ((db**) db*)
+ ((unwinder db*) (visit unwinder db env 'value))
+ ((db**) (concat db* db**))
+ ((pre db*) (visit pre (concat db** db) env 'effect))
+ ((db**) (concat db* db**))
+ ((body db*) (visit body (concat db** db) env ctx))
+ ((db**) (concat db* db**))
+ ((post db*) (visit post (concat db** db) env 'effect))
+ ((db**) (concat db* db**)))
+ (return (make-dynwind src winder pre body post unwinder)
+ db**)))
(($ <dynlet> src fluids vals body)
(let*-values (((fluids db*) (parallel-visit fluids db env 'value))
((vals db**) (parallel-visit vals db env 'value))
@@ -504,7 +505,7 @@
;; (if FOO A A) => (begin FOO A)
(($ <conditional> src _
($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
- (visit (make-sequence #f (list test (make-const #f a)))
+ (visit (make-seq #f test (make-const #f a))
db env ctx))
;; (if FOO #t #f) => FOO for boolean-valued FOO.
(($ <conditional> src
@@ -529,10 +530,13 @@
(c
(return c (intersection (concat db++ db+) (concat db-- db-)))))))
- (($ <application> src proc args)
+ (($ <primcall> src primitive args)
+ (let*-values (((args db*) (parallel-visit args db env 'value)))
+ (return (make-primcall src primitive args) db*)))
+ (($ <call> src proc args)
(let*-values (((proc db*) (visit proc db env 'value))
((args db**) (parallel-visit args db env 'value)))
- (return (make-application src proc args)
+ (return (make-call src proc args)
(concat db** db*))))
(($ <lambda> src meta body)
(let*-values (((body _) (if body
@@ -549,24 +553,15 @@
(values #f #f))))
(return (make-lambda-case src req opt rest kw inits gensyms body alt)
(if alt vlist-null db*))))
- (($ <sequence> src exps)
- (let lp ((in exps) (out '()) (db* vlist-null))
- (match in
- ((last)
- (let*-values (((last db**) (visit last (concat db* db) env ctx)))
- (if (null? out)
- (return last (concat db** db*))
- (return (make-sequence src (reverse (cons last out)))
- (concat db** db*)))))
- ((head . rest)
- (let*-values (((head db**) (visit head (concat db* db) env 'effect)))
- (cond
- ((sequence? head)
- (lp (append (sequence-exps head) rest) out db*))
- ((void? head)
- (lp rest out db*))
- (else
- (lp rest (cons head out) (concat db** db*)))))))))
+ (($ <seq> src head tail)
+ (let*-values (((head db*) (visit head db env 'effect)))
+ (cond
+ ((void? head)
+ (visit tail db env ctx))
+ (else
+ (let*-values (((tail db**) (visit tail (concat db* db) env ctx)))
+ (values (make-seq src head tail)
+ (concat db** db*)))))))
(($ <prompt> src tag body handler)
(let*-values (((tag db*) (visit tag db env 'value))
((body _) (visit body (concat db* db) env ctx))
diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm
index 97737c29b..65fd58e3c 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -216,9 +216,11 @@
(for-each (cut visit <> env) fluids)
(for-each (cut visit <> env) vals)
(visit body env))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(visit winder env)
+ (visit pre env)
(visit body env)
+ (visit post env)
(visit unwinder env))
(($ <dynref> src fluid)
(visit fluid env))
@@ -229,21 +231,24 @@
(visit condition env)
(visit subsequent env)
(visit alternate env))
- (($ <application> src proc args)
+ (($ <primcall> src name args)
(cond
+ ((not (symbol? name))
+ (error "expected symbolic operator" exp))
((not (list? args))
(error "expected list of args" args))
(else
- (visit proc env)
(for-each (cut visit <> env) args))))
- (($ <sequence> src exps)
+ (($ <call> src proc args)
(cond
- ((not (list? exps))
- (error "expected list of exps" exp))
- ((null? exps)
- (error "expected more than one exp" exp))
+ ((not (list? args))
+ (error "expected list of args" args))
(else
- (for-each (cut visit <> env) exps))))
+ (visit proc env)
+ (for-each (cut visit <> env) args))))
+ (($ <seq> src head tail)
+ (visit head env)
+ (visit tail env))
(($ <prompt> src tag body handler)
(visit tag env)
(visit body env)
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 1fe4aebb0..b5586e2b4 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -211,9 +211,11 @@ of an expression."
(logior (compute-effects producer)
(compute-effects consumer)
(cause &type-check)))
- (($ <dynwind> _ winder body unwinder)
+ (($ <dynwind> _ winder pre body post unwinder)
(logior (compute-effects winder)
+ (compute-effects pre)
(compute-effects body)
+ (compute-effects post)
(compute-effects unwinder)))
(($ <dynlet> _ fluids vals body)
(logior (accumulate-effects fluids)
@@ -259,43 +261,37 @@ of an expression."
&definite-bailout))))
;; Zero values.
- (($ <application> _ ($ <primitive-ref> _ 'values) ())
+ (($ <primcall> _ 'values ())
(cause &zero-values))
;; Effect-free primitives.
- (($ <application> _
- ($ <primitive-ref> _ (or 'values 'eq? 'eqv? 'equal?))
- args)
+ (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
(accumulate-effects args))
- (($ <application> _
- ($ <primitive-ref> _ (or 'not 'pair? 'null? 'list? 'symbol?
- 'vector? 'struct? 'string? 'number?
- 'char?))
+ (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
+ 'vector? 'struct? 'string? 'number?
+ 'char?)
(arg))
(compute-effects arg))
;; Primitives that allocate memory.
- (($ <application> _ ($ <primitive-ref> _ 'cons) (x y))
+ (($ <primcall> _ 'cons (x y))
(logior (compute-effects x) (compute-effects y)
&allocation))
- (($ <application> _ ($ <primitive-ref> _ (or 'list 'vector)) args)
+ (($ <primcall> _ (or 'list 'vector) args)
(logior (accumulate-effects args) &allocation))
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
+ (($ <primcall> _ 'make-prompt-tag ())
&allocation)
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (arg))
+ (($ <primcall> _ 'make-prompt-tag (arg))
(logior (compute-effects arg) &allocation))
;; Primitives that are normally effect-free, but which might
;; cause type checks, allocate memory, or access mutable
;; memory. FIXME: expand, to be more precise.
- (($ <application> _
- ($ <primitive-ref> _ (and name
- (? effect-free-primitive?)))
- args)
+ (($ <primcall> _ (and name (? effect-free-primitive?)) args)
(logior (accumulate-effects args)
(cause &type-check)
(if (constructor-primitive? name)
@@ -305,7 +301,7 @@ of an expression."
&no-effects))))
;; Lambda applications might throw wrong-number-of-args.
- (($ <application> _ ($ <lambda> _ _ body) args)
+ (($ <call> _ ($ <lambda> _ _ body) args)
(logior (accumulate-effects args)
(match body
(($ <lambda-case> _ req #f #f #f () syms body #f)
@@ -323,25 +319,27 @@ of an expression."
(cause &possible-bailout))))))
;; Bailout primitives.
- (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
- args)
+ (($ <primcall> _ (? bailout-primitive? name) args)
(logior (accumulate-effects args)
(cause &definite-bailout)
(cause &possible-bailout)))
;; A call to a lexically bound procedure, perhaps labels
;; allocated.
- (($ <application> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+ (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
(cond
((lookup sym)
=> (lambda (proc)
- (compute-effects (make-application #f proc args))))
+ (compute-effects (make-call #f proc args))))
(else
(logior &all-effects-but-bailout
(cause &all-effects-but-bailout)))))
;; A call to an unknown procedure can do anything.
- (($ <application> _ proc args)
+ (($ <primcall> _ name args)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))
+ (($ <call> _ proc args)
(logior &all-effects-but-bailout
(cause &all-effects-but-bailout)))
@@ -356,16 +354,13 @@ of an expression."
(compute-effects body)
(if alt (compute-effects alt) &no-effects)))
- (($ <sequence> _ exps)
- (let lp ((exps exps) (effects &no-effects))
- (match exps
- ((tail)
- (logior (compute-effects tail)
- ;; Returning zero values to a for-effect continuation is
- ;; not observable.
- (exclude-effects effects (cause &zero-values))))
- ((head . tail)
- (lp tail (logior (compute-effects head) effects))))))
+ (($ <seq> _ head tail)
+ (logior
+ ;; Returning zero values to a for-effect continuation is
+ ;; not observable.
+ (exclude-effects (compute-effects head)
+ (cause &zero-values))
+ (compute-effects tail)))
(($ <prompt> _ tag body handler)
(logior (compute-effects tag)
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index 60c87e389..b5722fe09 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -41,12 +41,11 @@
(and (simple-expression? test bound-vars simple-primcall?)
(simple-expression? consequent bound-vars simple-primcall?)
(simple-expression? alternate bound-vars simple-primcall?)))
- ((<sequence> exps)
- (and-map (lambda (x) (simple-expression? x bound-vars simple-primcall?))
- exps))
- ((<application> proc args)
- (and (primitive-ref? proc)
- (simple-primcall? x)
+ ((<seq> head tail)
+ (and (simple-expression? head bound-vars simple-primcall?)
+ (simple-expression? tail bound-vars simple-primcall?)))
+ ((<primcall> name args)
+ (and (simple-primcall? x)
(and-map (lambda (x)
(simple-expression? x bound-vars simple-primcall?))
args)))
@@ -191,19 +190,25 @@
'())))
(values unref simple lambda* complex)))
-(define (make-sequence* src exps)
- (let lp ((in exps) (out '()))
- (if (null? (cdr in))
- (if (null? out)
- (car in)
- (make-sequence src (reverse (cons (car in) out))))
- (let ((head (car in)))
- (record-case head
- ((<lambda>) (lp (cdr in) out))
- ((<const>) (lp (cdr in) out))
- ((<lexical-ref>) (lp (cdr in) out))
- ((<void>) (lp (cdr in) out))
- (else (lp (cdr in) (cons head out))))))))
+(define (make-seq* src head tail)
+ (record-case head
+ ((<lambda>) tail)
+ ((<const>) tail)
+ ((<lexical-ref>) tail)
+ ((<void>) tail)
+ (else (make-seq src head tail))))
+
+(define (list->seq* loc exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (let lp ((exps (cdr exps)) (effects (list (car exps))))
+ (if (null? (cdr exps))
+ (make-seq* loc
+ (fold (lambda (exp tail) (make-seq* #f exp tail))
+ (car effects)
+ (cdr effects))
+ (car exps))
+ (lp (cdr exps) (cons (car exps) effects))))))
(define (fix-letrec! x)
(let-values (((unref simple lambda* complex) (partition-vars x)))
@@ -215,7 +220,7 @@
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
- (make-sequence* #f (list exp (make-void #f)))
+ (make-seq* #f exp (make-void #f))
x))
((<letrec> src in-order? names gensyms vals body)
@@ -243,7 +248,7 @@
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
- (make-sequence*
+ (list->seq*
src
(append
;; The right-hand-sides of the unreferenced
@@ -270,7 +275,7 @@
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
- (make-sequence
+ (list->seq
#f
(map (lambda (x tmp)
(make-lexical-set
@@ -287,7 +292,7 @@
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
- (make-sequence*
+ (list->seq*
src
(append
;; unreferenced bindings, called for effect.
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index bf96179e0..fe637f0a5 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -109,9 +109,8 @@
(($ <primitive-ref>) #t)
(($ <module-ref>) #t)
(($ <toplevel-ref>) #t)
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (($ <primcall> _ (? singly-valued-primitive?)) #t)
+ (($ <primcall> _ 'values (val)) #t)
(($ <lambda>) #t)
(else #f)))
@@ -119,9 +118,7 @@
"Discard all but the first value of X."
(if (singly-valued-expression? x)
x
- (make-application (tree-il-src x)
- (make-primitive-ref #f 'values)
- (list x))))
+ (make-primcall (tree-il-src x) 'values (list x))))
;; Peval will do a one-pass analysis on the source program to determine
;; the set of assigned lexicals, and to identify unreferenced and
@@ -328,7 +325,7 @@
(%set-operand-residual-value!
op
(match val
- (($ <application> src ($ <primitive-ref> _ 'values) (first))
+ (($ <primcall> src 'values (first))
;; The continuation of a residualized binding does not need the
;; introduced `values' node, so undo the effects of truncation.
first)
@@ -401,18 +398,15 @@ top-level bindings from ENV and return the resulting expression."
(define local-toplevel-env
;; The top-level environment of the module being compiled.
- (match exp
- (($ <toplevel-define> _ name)
- (vhash-consq name #t env))
- (($ <sequence> _ exps)
- (fold (lambda (x r)
- (match x
- (($ <toplevel-define> _ name)
- (vhash-consq name #t r))
- (_ r)))
- env
- exps))
- (_ env)))
+ (let ()
+ (define (env-folder x env)
+ (match x
+ (($ <toplevel-define> _ name)
+ (vhash-consq name #t env))
+ (($ <seq> _ head tail)
+ (env-folder tail (env-folder head env)))
+ (_ env)))
+ (env-folder exp vlist-null)))
(define (local-toplevel? name)
(vhash-assq name local-toplevel-env))
@@ -492,15 +486,13 @@ top-level bindings from ENV and return the resulting expression."
(values #t results))))
(lambda _
(values #f '()))))
-
(define (make-values src values)
(match values
((single) single) ; 1 value
((_ ...) ; 0, or 2 or more values
- (make-application src (make-primitive-ref src 'values)
- values))))
+ (make-primcall src 'values values))))
(define (residualize-call)
- (make-application src (make-primitive-ref #f name) args))
+ (make-primcall src name args))
(cond
((every const? args)
(let-values (((success? values)
@@ -540,21 +532,21 @@ top-level bindings from ENV and return the resulting expression."
($ <toplevel-define>) ; the future
($ <module-set>) ;
($ <dynset>) ;
- ($ <application> src
- ($ <primitive-ref> _ (? singly-valued-primitive?))))
+ ($ <primcall> src (? singly-valued-primitive?)))
(and (<= nmin 1) (or (not nmax) (>= nmax 1))
- (make-application src (make-lambda #f '() consumer) (list exp))))
+ (make-call src (make-lambda #f '() consumer) (list exp))))
;; Statically-known number of values.
- (($ <application> src ($ <primitive-ref> _ 'values) vals)
+ (($ <primcall> src 'values vals)
(and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals)))
- (make-application src (make-lambda #f '() consumer) vals)))
+ (make-call src (make-lambda #f '() consumer) vals)))
;; Not going to copy code into both branches.
(($ <conditional>) #f)
;; Bail on other applications.
- (($ <application>) #f)
+ (($ <call>) #f)
+ (($ <primcall>) #f)
;; Bail on prompt and abort.
(($ <prompt>) #f)
@@ -580,20 +572,17 @@ top-level bindings from ENV and return the resulting expression."
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(let ((body (loop body)))
(and body
- (make-dynwind src winder body unwinder))))
+ (make-dynwind src winder pre body post unwinder))))
(($ <dynlet> src fluids vals body)
(let ((body (loop body)))
(and body
(make-dynlet src fluids vals body))))
- (($ <sequence> src exps)
- (match exps
- ((head ... tail)
- (let ((tail (loop tail)))
- (and tail
- (make-sequence src (append head (list tail)))))))))))
+ (($ <seq> src head tail)
+ (let ((tail (loop tail)))
+ (and tail (make-seq src head tail)))))))
(define compute-effects
(make-effects-analyzer assigned-lexical?))
@@ -640,7 +629,7 @@ top-level bindings from ENV and return the resulting expression."
(if (null? effects)
body
(let ((effect-vals (map operand-residual-value effects)))
- (make-sequence #f (reverse (cons body effect-vals)))))))
+ (list->seq #f (reverse (cons body effect-vals)))))))
(if (null? values)
body
(let ((values (reverse values)))
@@ -875,16 +864,15 @@ top-level bindings from ENV and return the resulting expression."
(let ((exp (for-effect exp)))
(if (void? exp)
exp
- (make-sequence src (list exp (make-void #f)))))
+ (make-seq src exp (make-void #f))))
(begin
(record-operand-use op)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
(($ <let> src
(names ... rest)
(gensyms ... rest-sym)
- (vals ... ($ <application> _ ($ <primitive-ref> _ 'list) rest-args))
- ($ <application> asrc
- ($ <primitive-ref> _ (or 'apply '@apply))
+ (vals ... ($ <primcall> _ 'list rest-args))
+ ($ <primcall> asrc (or 'apply '@apply)
(proc args ...
($ <lexical-ref> _
(? (cut eq? <> rest))
@@ -898,7 +886,7 @@ top-level bindings from ENV and return the resulting expression."
(append names tmps)
(append gensyms tmp-syms)
(append vals rest-args)
- (make-application
+ (make-call
asrc
proc
(append args
@@ -940,14 +928,14 @@ top-level bindings from ENV and return the resulting expression."
(body (loop body env counter ctx)))
(cond
((const? body)
- (for-tail (make-sequence src (append vals (list body)))))
+ (for-tail (list->seq src (append vals (list body)))))
((and (lexical-ref? body)
(memq (lexical-ref-gensym body) new))
(let ((sym (lexical-ref-gensym body))
(pairs (map cons new vals)))
;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
(for-tail
- (make-sequence
+ (list->seq
src
(append (map cdr (alist-delete sym pairs eq?))
(list (assq-ref pairs sym)))))))
@@ -1008,40 +996,10 @@ top-level bindings from ENV and return the resulting expression."
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder body unwinder)
- (let ((pre (for-value winder))
- (body (for-tail body))
- (post (for-value unwinder)))
- (cond
- ((not (constant-expression? pre))
- (cond
- ((not (constant-expression? post))
- (let ((pre-sym (gensym "pre-")) (post-sym (gensym "post-")))
- (record-new-temporary! 'pre pre-sym 1)
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(pre post) (list pre-sym post-sym) (list pre post)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (let ((pre-sym (gensym "pre-")))
- (record-new-temporary! 'pre pre-sym 1)
- (make-let src '(pre) (list pre-sym) (list pre)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- post))))))
- ((not (constant-expression? post))
- (let ((post-sym (gensym "post-")))
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(post) (list post-sym) (list post)
- (make-dynwind src
- pre
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (make-dynwind src pre body post)))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (make-dynwind src (for-value winder) (for-effect pre)
+ (for-tail body)
+ (for-effect post) (for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
@@ -1050,12 +1008,7 @@ top-level bindings from ENV and return the resulting expression."
(($ <dynset> src fluid exp)
(make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
- (if (local-toplevel? name)
- exp
- (let ((exp (resolve-primitives! exp cenv)))
- (if (primitive-ref? exp)
- (for-tail exp)
- exp))))
+ exp)
(($ <toplevel-ref>)
;; todo: open private local bindings.
exp)
@@ -1084,7 +1037,8 @@ top-level bindings from ENV and return the resulting expression."
(($ <conditional> src condition subsequent alternate)
(define (call-with-failure-thunk exp proc)
(match exp
- (($ <application> _ _ ()) (proc exp))
+ (($ <call> _ _ ()) (proc exp))
+ (($ <primcall> _ _ ()) (proc exp))
(($ <const>) (proc exp))
(($ <void>) (proc exp))
(($ <lexical-ref>) (proc exp))
@@ -1097,13 +1051,12 @@ top-level bindings from ENV and return the resulting expression."
(make-lambda
#f '()
(make-lambda-case #f '() #f #f #f '() '() exp #f)))
- (proc (make-application #f (make-lexical-ref #f 'failure t)
- '())))))))
+ (proc (make-call #f (make-lexical-ref #f 'failure t)
+ '())))))))
(define (simplify-conditional c)
(match c
;; Swap the arms of (if (not FOO) A B), to simplify.
- (($ <conditional> src
- ($ <application> _ ($ <primitive-ref> _ 'not) (pred))
+ (($ <conditional> src ($ <primcall> _ 'not (pred))
subsequent alternate)
(simplify-conditional
(make-conditional src pred alternate subsequent)))
@@ -1155,17 +1108,59 @@ top-level bindings from ENV and return the resulting expression."
(simplify-conditional
(make-conditional src c (for-tail subsequent)
(for-tail alternate))))))
- (($ <application> src
- ($ <primitive-ref> _ '@call-with-values)
+ (($ <primcall> src '@call-with-values
(producer
($ <lambda> _ _
(and consumer
;; No optional or kwargs.
($ <lambda-case>
_ req #f rest #f () gensyms body #f)))))
- (for-tail (make-let-values src (make-application src producer '())
+ (for-tail (make-let-values src (make-call src producer '())
consumer)))
- (($ <application> src ($ <primitive-ref> _ 'values) exps)
+ (($ <primcall> src 'dynamic-wind (w thunk u))
+ (for-tail
+ (cond
+ ((not (constant-expression? w))
+ (cond
+ ((not (constant-expression? u))
+ (let ((w-sym (gensym "w ")) (u-sym (gensym "u ")))
+ (record-new-temporary! 'w w-sym 2)
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(w u) (list w-sym u-sym) (list w u)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (let ((w-sym (gensym "w ")))
+ (record-new-temporary! 'w w-sym 2)
+ (make-let src '(w) (list w-sym) (list w)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f u '())
+ u))))))
+ ((not (constant-expression? u))
+ (let ((u-sym (gensym "u ")))
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(u) (list u-sym) (list u)
+ (make-dynwind
+ src
+ w
+ (make-call #f w '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (make-dynwind src w (make-call #f w '()) (make-call #f thunk '())
+ (make-call #f u '()) u)))))
+
+ (($ <primcall> src 'values exps)
(cond
((null? exps)
(if (eq? ctx 'effect)
@@ -1177,10 +1172,10 @@ top-level bindings from ENV and return the resulting expression."
((value test effect) #t)
(else (null? (cdr vals))))
(every singly-valued-expression? vals))
- (for-tail (make-sequence src (append (cdr vals) (list (car vals)))))
- (make-application src (make-primitive-ref #f 'values) vals))))))
- (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply '@apply)))
- (proc args ... tail))
+ (for-tail (list->seq src (append (cdr vals) (list (car vals)))))
+ (make-primcall src 'values vals))))))
+
+ (($ <primcall> src (or 'apply '@apply) (proc args ... tail))
(let lp ((tail* (find-definition tail 1)) (speculative? #t))
(define (copyable? x)
;; Inlining a result from find-definition effectively copies it,
@@ -1190,126 +1185,133 @@ top-level bindings from ENV and return the resulting expression."
(match tail*
(($ <const> _ (args* ...))
(let ((args* (map (cut make-const #f <>) args*)))
- (for-tail (make-application src proc (append args args*)))))
- (($ <application> _ ($ <primitive-ref> _ 'cons)
+ (for-tail (make-call src proc (append args args*)))))
+ (($ <primcall> _ 'cons
((and head (? copyable?)) (and tail (? copyable?))))
- (for-tail (make-application src apply
- (cons proc
- (append args (list head tail))))))
- (($ <application> _ ($ <primitive-ref> _ 'list)
+ (for-tail (make-primcall src '@apply
+ (cons proc
+ (append args (list head tail))))))
+ (($ <primcall> _ 'list
(and args* ((? copyable?) ...)))
- (for-tail (make-application src proc (append args args*))))
+ (for-tail (make-call src proc (append args args*))))
(tail*
(if speculative?
(lp (for-value tail) #f)
(let ((args (append (map for-value args) (list tail*))))
- (make-application src apply
- (cons (for-value proc) args))))))))
- (($ <application> src orig-proc orig-args)
+ (make-primcall src '@apply
+ (cons (for-value proc) args))))))))
+
+ (($ <primcall> src (? constructor-primitive? name) args)
+ (cond
+ ((and (memq ctx '(effect test))
+ (match (cons name args)
+ ((or ('cons _ _)
+ ('list . _)
+ ('vector . _)
+ ('make-prompt-tag)
+ ('make-prompt-tag ($ <const> _ (? string?))))
+ #t)
+ (_ #f)))
+ ;; Some expressions can be folded without visiting the
+ ;; arguments for value.
+ (let ((res (if (eq? ctx 'effect)
+ (make-void #f)
+ (make-const #f #t))))
+ (for-tail (list->seq src (append args (list res))))))
+ (else
+ (match (cons name (map for-value args))
+ (('cons x ($ <const> _ (? (cut eq? <> '()))))
+ (make-primcall src 'list (list x)))
+ (('cons x ($ <primcall> _ 'list elts))
+ (make-primcall src 'list (cons x elts)))
+ ((name . args)
+ (make-primcall src name args))))))
+
+ (($ <primcall> src (? accessor-primitive? name) args)
+ (match (cons name (map for-value args))
+ ;; FIXME: these for-tail recursions could take place outside
+ ;; an effort counter.
+ (('car ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src tail head)))
+ (('cdr ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src head tail)))
+ (('car ($ <primcall> src 'list (head . tail)))
+ (for-tail (list->seq src (append tail (list head)))))
+ (('cdr ($ <primcall> src 'list (head . tail)))
+ (for-tail (make-seq src head (make-primcall #f 'list tail))))
+
+ (('car ($ <const> src (head . tail)))
+ (for-tail (make-const src head)))
+ (('cdr ($ <const> src (head . tail)))
+ (for-tail (make-const src tail)))
+ (((or 'memq 'memv) k ($ <const> _ (elts ...)))
+ ;; FIXME: factor
+ (case ctx
+ ((effect)
+ (for-tail
+ (make-seq src k (make-void #f))))
+ ((test)
+ (cond
+ ((const? k)
+ ;; A shortcut. The `else' case would handle it, but
+ ;; this way is faster.
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (and (member (const-exp k) elts) #t))))
+ ((null? elts)
+ (for-tail
+ (make-seq src k (make-const #f #f))))
+ (else
+ (let ((t (gensym "t "))
+ (eq (if (eq? name 'memq) 'eq? 'eqv?)))
+ (record-new-temporary! 't t (length elts))
+ (for-tail
+ (make-let
+ src (list 't) (list t) (list k)
+ (let lp ((elts elts))
+ (define test
+ (make-primcall #f eq
+ (list (make-lexical-ref #f 't t)
+ (make-const #f (car elts)))))
+ (if (null? (cdr elts))
+ test
+ (make-conditional src test
+ (make-const #f #t)
+ (lp (cdr elts)))))))))))
+ (else
+ (cond
+ ((const? k)
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (member (const-exp k) elts))))
+ ((null? elts)
+ (for-tail (make-seq src k (make-const #f #f))))
+ (else
+ (make-primcall src name (list k (make-const #f elts))))))))
+ ((name . args)
+ (fold-constants src name args ctx))))
+
+ (($ <primcall> src (? equality-primitive? name) (a b))
+ (let ((val-a (for-value a))
+ (val-b (for-value b)))
+ (log 'equality-primitive name val-a val-b)
+ (cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
+ (eq? (lexical-ref-gensym val-a)
+ (lexical-ref-gensym val-b)))
+ (for-tail (make-const #f #t)))
+ (else
+ (fold-constants src name (list val-a val-b) ctx)))))
+
+ (($ <primcall> src (? effect-free-primitive? name) args)
+ (fold-constants src name (map for-value args) ctx))
+
+ (($ <primcall> src name args)
+ (make-primcall src name (map for-value args)))
+
+ (($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let revisit-proc ((proc (visit orig-proc 'operator)))
(match proc
- (($ <primitive-ref> _ (? constructor-primitive? name))
- (cond
- ((and (memq ctx '(effect test))
- (match (cons name orig-args)
- ((or ('cons _ _)
- ('list . _)
- ('vector . _)
- ('make-prompt-tag)
- ('make-prompt-tag ($ <const> _ (? string?))))
- #t)
- (_ #f)))
- ;; Some expressions can be folded without visiting the
- ;; arguments for value.
- (let ((res (if (eq? ctx 'effect)
- (make-void #f)
- (make-const #f #t))))
- (for-tail (make-sequence src (append orig-args (list res))))))
- (else
- (match (cons name (map for-value orig-args))
- (('cons head tail)
- (match tail
- (($ <const> src (? (cut eq? <> '())))
- (make-application src (make-primitive-ref #f 'list)
- (list head)))
- (($ <application> src ($ <primitive-ref> _ 'list) elts)
- (make-application src (make-primitive-ref #f 'list)
- (cons head elts)))
- (_ (make-application src proc (list head tail)))))
- ((_ . args)
- (make-application src proc args))))))
- (($ <primitive-ref> _ (? accessor-primitive? name))
- (match (cons name (map for-value orig-args))
- ;; FIXME: these for-tail recursions could take place outside
- ;; an effort counter.
- (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list tail head))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list head tail))))
- (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence src (append tail (list head)))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence
- src
- (list head
- (make-application
- src (make-primitive-ref #f 'list) tail)))))
-
- (('car ($ <const> src (head . tail)))
- (for-tail (make-const src head)))
- (('cdr ($ <const> src (head . tail)))
- (for-tail (make-const src tail)))
- (((or 'memq 'memv) k ($ <const> _ (elts ...)))
- ;; FIXME: factor
- (case ctx
- ((effect)
- (for-tail
- (make-sequence src (list k (make-void #f)))))
- ((test)
- (cond
- ((const? k)
- ;; A shortcut. The `else' case would handle it, but
- ;; this way is faster.
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (and (member (const-exp k) elts) #t))))
- ((null? elts)
- (for-tail
- (make-sequence src (list k (make-const #f #f)))))
- (else
- (let ((t (gensym "t-"))
- (eq (if (eq? name 'memq) 'eq? 'eqv?)))
- (record-new-temporary! 't t (length elts))
- (for-tail
- (make-let
- src (list 't) (list t) (list k)
- (let lp ((elts elts))
- (define test
- (make-application
- #f (make-primitive-ref #f eq)
- (list (make-lexical-ref #f 't t)
- (make-const #f (car elts)))))
- (if (null? (cdr elts))
- test
- (make-conditional src test
- (make-const #f #t)
- (lp (cdr elts)))))))))))
- (else
- (cond
- ((const? k)
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (member (const-exp k) elts))))
- ((null? elts)
- (for-tail (make-sequence src (list k (make-const #f #f)))))
- (else
- (make-application src proc (list k (make-const #f elts))))))))
- ((_ . args)
- (or (fold-constants src name args ctx)
- (make-application src proc args)))))
- (($ <primitive-ref> _ (? effect-free-primitive? name))
- (let ((args (map for-value orig-args)))
- (or (fold-constants src name args ctx)
- (make-application src proc args))))
+ (($ <primitive-ref> _ name)
+ (for-tail (make-primcall src name orig-args)))
(($ <lambda> _ _
($ <lambda-case> _ req opt rest #f inits gensyms body #f))
;; Simple case: no keyword arguments.
@@ -1318,7 +1320,7 @@ top-level bindings from ENV and return the resulting expression."
(nreq (length req))
(nopt (if opt (length opt) 0))
(key (source-expression proc)))
- (define (inlined-application)
+ (define (inlined-call)
(make-let src
(append req
(or opt '())
@@ -1327,9 +1329,8 @@ top-level bindings from ENV and return the resulting expression."
(if (> nargs (+ nreq nopt))
(append (list-head orig-args (+ nreq nopt))
(list
- (make-application
- #f
- (make-primitive-ref #f 'list)
+ (make-primcall
+ #f 'list
(drop orig-args (+ nreq nopt)))))
(append orig-args
(drop inits (- nargs nreq))
@@ -1341,8 +1342,7 @@ top-level bindings from ENV and return the resulting expression."
(cond
((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
;; An error, or effecting arguments.
- (make-application src (for-call orig-proc)
- (map for-value orig-args)))
+ (make-call src (for-call orig-proc) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?)
(lambda? orig-proc))
;; A recursive call, or a lambda in the operator
@@ -1364,7 +1364,7 @@ top-level bindings from ENV and return the resulting expression."
(lp (counter-prev counter)))))))
(log 'inline-recurse key)
- (loop (inlined-application) env counter ctx))
+ (loop (inlined-call) env counter ctx))
(else
;; An integration at the top-level, the first
;; recursion of a recursive procedure, or a nested
@@ -1374,8 +1374,8 @@ top-level bindings from ENV and return the resulting expression."
(let/ec k
(define (abort)
(log 'inline-abort exp)
- (k (make-application src (for-call orig-proc)
- (map for-value orig-args))))
+ (k (make-call src (for-call orig-proc)
+ (map for-value orig-args))))
(define new-counter
(cond
;; These first two cases will transfer effort
@@ -1395,7 +1395,7 @@ top-level bindings from ENV and return the resulting expression."
(make-top-counter effort-limit operand-size-limit
abort key))))
(define result
- (loop (inlined-application) env new-counter ctx))
+ (loop (inlined-call) env new-counter ctx))
(if counter
;; The nested inlining attempt succeeded.
@@ -1420,7 +1420,7 @@ top-level bindings from ENV and return the resulting expression."
(log 'inline-let orig-proc)
(for-tail
(make-let lsrc names syms vals
- (make-application src body orig-args))))
+ (make-call src body orig-args))))
;; It's possible for a `let' to go away after the
;; visit due to the fact that visiting a procedure in
;; value context will prune unused bindings, whereas
@@ -1428,11 +1428,10 @@ top-level bindings from ENV and return the resulting expression."
;; traverse through lambdas. In that case re-visit
;; the procedure.
(proc (revisit-proc proc)))
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))
+ (make-call src (for-call orig-proc)
+ (map for-value orig-args))))
(_
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))))
+ (make-call src (for-call orig-proc) (map for-value orig-args))))))
(($ <lambda> src meta body)
(case ctx
((effect) (make-void #f))
@@ -1445,8 +1444,7 @@ top-level bindings from ENV and return the resulting expression."
(define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw)
(match body
- (($ <application> _
- ($ <primitive-ref> _ '@apply)
+ (($ <primcall> _ '@apply
(($ <lambda> _ _ (and lcase ($ <lambda-case>)))
($ <lexical-ref> _ _ sym)
...))
@@ -1473,29 +1471,21 @@ top-level bindings from ENV and return the resulting expression."
new
body
(and alt (for-tail alt))))))
- (($ <sequence> src exps)
- (let lp ((exps exps) (effects '()))
- (match exps
- ((last)
- (if (null? effects)
- (for-tail last)
- (make-sequence
- src
- (reverse (cons (for-tail last) effects)))))
- ((head . rest)
- (let ((head (for-effect head)))
- (cond
- ((sequence? head)
- (lp (append (sequence-exps head) rest) effects))
- ((void? head)
- (lp rest effects))
- (else
- (lp rest (cons head effects)))))))))
+ (($ <seq> src head tail)
+ (let ((head (for-effect head))
+ (tail (for-tail tail)))
+ (if (void? head)
+ tail
+ (make-seq src
+ (if (and (seq? head)
+ (void? (seq-tail head)))
+ (seq-head head)
+ head)
+ tail))))
(($ <prompt> src tag body handler)
(define (make-prompt-tag? x)
(match x
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
- (or () ((? constant-expression?))))
+ (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
#t)
(_ #f)))
@@ -1527,11 +1517,11 @@ top-level bindings from ENV and return the resulting expression."
(for-tail
(make-let-values
src
- (make-application #f (make-primitive-ref #f 'apply)
- `(,(make-primitive-ref #f 'values)
- ,(make-primitive-ref #f 'values)
- ,@(abort-args body)
- ,(abort-tail body)))
+ (make-primcall #f 'apply
+ `(,(make-primitive-ref #f 'values)
+ ,(make-primitive-ref #f 'values)
+ ,@(abort-args body)
+ ,(abort-tail body)))
(for-value handler)))))
(else
(make-prompt src tag body (for-value handler))))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index bac3136e3..e3f6a9071 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,7 +29,8 @@
expand-primitives!
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? accessor-primitive?
- singly-valued-primitive? bailout-primitive?
+ singly-valued-primitive? equality-primitive?
+ bailout-primitive?
negate-primitive))
;; When adding to this, be sure to update *multiply-valued-primitives*
@@ -48,7 +49,7 @@
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor lognot
not
- pair? null? list? symbol? vector? string? struct? number? char?
+ pair? null? list? symbol? vector? string? struct? number? char? nil?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
@@ -70,7 +71,7 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
+ vector-length vector-ref vector-set!
variable-ref variable-set!
variable-bound?
@@ -153,12 +154,12 @@
ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string? number? char?
+ pair? null? list? symbol? vector? struct? string? number? char? nil
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
char<? char<=? char>=? char>?
integer->char char->integer number->string string->number
struct-vtable
- string-length
+ string-length vector-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
@@ -200,8 +201,12 @@
(char<? . char>=?)
(char>? . char<=?)))
+(define *equality-primitives*
+ '(eq? eqv? equal?))
+
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
+(define *equality-primitive-table* (make-hash-table))
(define *multiply-valued-primitive-table* (make-hash-table))
(define *bailout-primitive-table* (make-hash-table))
(define *negatable-primitive-table* (make-hash-table))
@@ -212,6 +217,9 @@
(for-each (lambda (x)
(hashq-set! *effect+exceptions-free-primitive-table* x #t))
*effect+exception-free-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *equality-primitive-table* x #t))
+ *equality-primitives*)
(for-each (lambda (x)
(hashq-set! *multiply-valued-primitive-table* x #t))
*multiply-valued-primitives*)
@@ -231,6 +239,8 @@
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
(hashq-ref *effect+exceptions-free-primitive-table* prim))
+(define (equality-primitive? prim)
+ (hashq-ref *equality-primitive-table* prim))
(define (singly-valued-primitive? prim)
(not (hashq-ref *multiply-valued-primitive-table* prim)))
(define (bailout-primitive? prim)
@@ -239,14 +249,29 @@
(hashq-ref *negatable-primitive-table* prim))
(define (resolve-primitives! x mod)
+ (define local-definitions
+ (make-hash-table))
+
+ (let collect-local-definitions ((x x))
+ (record-case x
+ ((<toplevel-define> name)
+ (hashq-set! local-definitions name #t))
+ ((<seq> head tail)
+ (collect-local-definitions head)
+ (collect-local-definitions tail))
+ (else #f)))
+
(post-order!
(lambda (x)
(record-case x
((<toplevel-ref> src name)
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable mod name))
+ (and=> (and (not (hashq-ref local-definitions name))
+ (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name)))
(lambda (name) (make-primitive-ref src name))))
((<module-ref> src mod name public?)
+ ;; for the moment, we're disabling primitive resolution for
+ ;; public refs because resolve-interface can raise errors.
(and=> (and=> (resolve-module mod)
(if public?
module-public-interface
@@ -256,6 +281,9 @@
(module-variable m name))
(lambda (name)
(make-primitive-ref src name))))))
+ ((<call> src proc args)
+ (and (primitive-ref? proc)
+ (make-primcall src (primitive-ref-name proc) args)))
(else #f)))
x))
@@ -267,11 +295,9 @@
(pre-order!
(lambda (x)
(record-case x
- ((<application> src proc args)
- (and (primitive-ref? proc)
- (let ((expand (hashq-ref *primitive-expand-table*
- (primitive-ref-name proc))))
- (and expand (apply expand src args)))))
+ ((<primcall> src name args)
+ (let ((expand (hashq-ref *primitive-expand-table* name)))
+ (and expand (apply expand src args))))
(else #f)))
x))
@@ -287,8 +313,8 @@
(lp (cdr in)
(cons (if (eq? (caar in) 'quote)
`(make-const src ,@(cdar in))
- `(make-application src (make-primitive-ref src ',(caar in))
- ,(inline-args (cdar in))))
+ `(make-primcall src ',(caar in)
+ ,(inline-args (cdar in))))
out)))
((symbol? (car in))
;; assume it's locally bound
@@ -306,8 +332,8 @@
,(consequent then)
,(consequent else)))
(else
- `(make-application src (make-primitive-ref src ',(car exp))
- ,(inline-args (cdr exp))))))
+ `(make-primcall src ',(car exp)
+ ,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
@@ -502,9 +528,9 @@
(symbol? v)
(and (integer? v)
(exact? v)
- (<= most-negative-fixnum v most-positive-fixnum)))
- (make-application src (make-primitive-ref #f 'eq?)
- (list a b))))))
+ (<= v most-positive-fixnum)
+ (>= v most-negative-fixnum)))
+ (make-primcall src 'eq? (list a b))))))
(or (maybe-simplify a b) (maybe-simplify b a)))
(else #f)))
@@ -512,25 +538,6 @@
(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
(hashq-set! *primitive-expand-table*
- 'dynamic-wind
- (case-lambda
- ((src pre thunk post)
- (let ((PRE (gensym "pre-"))
- (THUNK (gensym "thunk-"))
- (POST (gensym "post-")))
- (make-let
- src
- '(pre thunk post)
- (list PRE THUNK POST)
- (list pre thunk post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
- (make-lexical-ref #f 'post POST)))))
- (else #f)))
-
-(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
((src pre expr post)
@@ -544,7 +551,9 @@
(make-dynwind
src
(make-lexical-ref #f 'pre PRE)
+ (make-call #f (make-lexical-ref #f 'pre PRE) '())
expr
+ (make-call #f (make-lexical-ref #f 'post POST) '())
(make-lexical-ref #f 'post POST)))))))
(hashq-set! *primitive-expand-table*
@@ -570,9 +579,9 @@
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args args-sym)))
+ (make-primcall #f 'apply
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
#f))))
(else #f)))
@@ -585,13 +594,13 @@
(make-let
src '(handler) (list handler-sym) (list handler)
(make-prompt
- src tag (make-application #f thunk '())
+ src tag (make-call #f thunk '())
;; If handler itself is a lambda, the inliner can do some
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application
- #f (make-primitive-ref #f 'apply)
+ (make-primcall
+ #f 'apply
(list (make-lexical-ref #f 'handler handler-sym)
(make-lexical-ref #f 'args args-sym)))
#f)))))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index bb7a200b7..80c32fe29 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -1,6 +1,6 @@
;;; Tree Intermediate Language
-;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -33,7 +33,9 @@
(pmatch exps
(() (make-void #f))
((,x) x)
- (else (make-sequence #f exps))))
+ ((,x . ,rest)
+ (make-seq #f x (join rest env)))
+ (else (error "what!" exps env))))
(define-language tree-il
#:title "Tree Intermediate Language"
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 8e548d8e9..2e875fa4b 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -25,54 +25,112 @@
;;;;
(define-module (oop goops)
- :use-module (srfi srfi-1)
- :export-syntax (define-class class standard-define-class
- define-generic define-accessor define-method
- define-extended-generic define-extended-generics
- method)
- :export (is-a? class-of
- ensure-metaclass ensure-metaclass-with-supers
- make-class
- make-generic ensure-generic
- make-extended-generic
- make-accessor ensure-accessor
- add-method!
- class-slot-ref class-slot-set! slot-unbound slot-missing
- slot-definition-name slot-definition-options
- slot-definition-allocation
- slot-definition-getter slot-definition-setter
- slot-definition-accessor
- slot-definition-init-value slot-definition-init-form
- slot-definition-init-thunk slot-definition-init-keyword
- slot-init-function class-slot-definition
- method-source
- compute-cpl compute-std-cpl compute-get-n-set compute-slots
- compute-getter-method compute-setter-method
- allocate-instance initialize make-instance make
- no-next-method no-applicable-method no-method
- change-class update-instance-for-different-class
- shallow-clone deep-clone
- class-redefinition
- apply-generic apply-method apply-methods
- compute-applicable-methods %compute-applicable-methods
- method-more-specific? sort-applicable-methods
- class-subclasses class-methods
- goops-error
- min-fixnum max-fixnum
- ;;; *fixme* Should go into goops.c
- instance? slot-ref-using-class
- slot-set-using-class! slot-bound-using-class?
- slot-exists-using-class? slot-ref slot-set! slot-bound?
- class-name class-direct-supers class-direct-subclasses
- class-direct-methods class-direct-slots class-precedence-list
- class-slots
- generic-function-name
- generic-function-methods method-generic-function
- method-specializers method-formals
- primitive-generic-generic enable-primitive-generic!
- method-procedure accessor-method-slot-definition
- slot-exists? make find-method get-keyword)
- :no-backtrace)
+ #:use-module (srfi srfi-1)
+ #:export-syntax (define-class class standard-define-class
+ define-generic define-accessor define-method
+ define-extended-generic define-extended-generics
+ method)
+ #:export ( ;; The root of everything.
+ <top>
+ <class> <object>
+
+ ;; Slot types.
+ <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
+ <read-only-slot> <self-slot> <protected-opaque-slot>
+ <protected-hidden-slot> <protected-read-only-slot>
+ <scm-slot> <int-slot> <float-slot> <double-slot>
+
+ ;; Methods are implementations of generic functions.
+ <method> <accessor-method>
+
+ ;; Applicable objects, either procedures or applicable structs.
+ <procedure-class> <applicable>
+ <procedure> <primitive-generic>
+
+ ;; Applicable structs.
+ <applicable-struct-class>
+ <applicable-struct>
+ <generic> <extended-generic>
+ <generic-with-setter> <extended-generic-with-setter>
+ <accessor> <extended-accessor>
+
+ ;; Types with their own allocated typecodes.
+ <boolean> <char> <list> <pair> <null> <string> <symbol>
+ <vector> <bytevector> <uvec> <foreign> <hashtable>
+ <fluid> <dynamic-state> <frame> <objcode> <vm> <vm-continuation>
+
+ ;; Numbers.
+ <number> <complex> <real> <integer> <fraction>
+
+ ;; Unknown.
+ <unknown>
+
+ ;; Particular SMOB data types. All SMOB types have
+ ;; corresponding classes, which may be obtained via class-of,
+ ;; once you have an instance. Perhaps FIXME to provide a
+ ;; smob-type-name->class procedure.
+ <arbiter> <promise> <thread> <mutex> <condition-variable>
+ <regexp> <hook> <bitvector> <random-state> <async>
+ <directory> <keyword> <array> <character-set>
+ <dynamic-object> <guardian> <macro>
+
+ ;; Modules.
+ <module>
+
+ ;; Ports.
+ <port> <input-port> <output-port> <input-output-port>
+
+ ;; Like SMOB types, all port types have their own classes,
+ ;; which can be accessed via `class-of' once you have an
+ ;; instance. Here we export bindings just for file ports.
+ <file-port>
+ <file-input-port> <file-output-port> <file-input-output-port>
+
+ is-a? class-of
+ ensure-metaclass ensure-metaclass-with-supers
+ make-class
+ make-generic ensure-generic
+ make-extended-generic
+ make-accessor ensure-accessor
+ add-method!
+ class-slot-ref class-slot-set! slot-unbound slot-missing
+ slot-definition-name slot-definition-options
+ slot-definition-allocation
+
+ slot-definition-getter slot-definition-setter
+ slot-definition-accessor
+ slot-definition-init-value slot-definition-init-form
+ slot-definition-init-thunk slot-definition-init-keyword
+ slot-init-function class-slot-definition
+ method-source
+ compute-cpl compute-std-cpl compute-get-n-set compute-slots
+ compute-getter-method compute-setter-method
+ allocate-instance initialize make-instance make
+ no-next-method no-applicable-method no-method
+ change-class update-instance-for-different-class
+ shallow-clone deep-clone
+ class-redefinition
+ apply-generic apply-method apply-methods
+ compute-applicable-methods %compute-applicable-methods
+ method-more-specific? sort-applicable-methods
+ class-subclasses class-methods
+ goops-error
+ min-fixnum max-fixnum
+
+;;; *fixme* Should go into goops.c
+ instance? slot-ref-using-class
+ slot-set-using-class! slot-bound-using-class?
+ slot-exists-using-class? slot-ref slot-set! slot-bound?
+ class-name class-direct-supers class-direct-subclasses
+ class-direct-methods class-direct-slots class-precedence-list
+ class-slots
+ generic-function-name
+ generic-function-methods method-generic-function
+ method-specializers method-formals
+ primitive-generic-generic enable-primitive-generic!
+ method-procedure accessor-method-slot-definition
+ slot-exists? make find-method get-keyword)
+ #:no-backtrace)
(define *goops-module* (current-module))
@@ -96,6 +154,7 @@
(oop goops compile))
+;; FIXME: deprecate.
(eval-when (eval load compile)
(define min-fixnum (- (expt 2 29)))
(define max-fixnum (- (expt 2 29) 1)))
@@ -814,6 +873,20 @@
;;; Handling of duplicate bindings in the module system
;;;
+(define (find-subclass super name)
+ (let lp ((classes (class-direct-subclasses super)))
+ (cond
+ ((null? classes)
+ (error "class not found" name))
+ ((and (slot-bound? (car classes) 'name)
+ (eq? (class-name (car classes)) name))
+ (car classes))
+ (else
+ (lp (cdr classes))))))
+
+;; A record type.
+(define <module> (find-subclass <top> '<module>))
+
(define-method (merge-generics (module <module>)
(name <symbol>)
(int1 <module>)
@@ -1659,3 +1732,34 @@
;; Tell C code that the main bulk of Goops has been loaded
(%goops-loaded)
+
+
+
+
+;;;
+;;; {SMOB and port classes}
+;;;
+
+(define <arbiter> (find-subclass <top> '<arbiter>))
+(define <promise> (find-subclass <top> '<promise>))
+(define <thread> (find-subclass <top> '<thread>))
+(define <mutex> (find-subclass <top> '<mutex>))
+(define <condition-variable> (find-subclass <top> '<condition-variable>))
+(define <regexp> (find-subclass <top> '<regexp>))
+(define <hook> (find-subclass <top> '<hook>))
+(define <bitvector> (find-subclass <top> '<bitvector>))
+(define <random-state> (find-subclass <top> '<random-state>))
+(define <async> (find-subclass <top> '<async>))
+(define <directory> (find-subclass <top> '<directory>))
+(define <keyword> (find-subclass <top> '<keyword>))
+(define <array> (find-subclass <top> '<array>))
+(define <character-set> (find-subclass <top> '<character-set>))
+(define <dynamic-object> (find-subclass <top> '<dynamic-object>))
+(define <guardian> (find-subclass <applicable> '<guardian>))
+(define <macro> (find-subclass <top> '<macro>))
+
+(define (define-class-subtree class)
+ (define! (class-name class) class)
+ (for-each define-class-subtree (class-direct-subclasses class)))
+
+(define-class-subtree (find-subclass <port> '<file-port>))
diff --git a/module/oop/goops/util.scm b/module/oop/goops/util.scm
index af72bc3f5..3c86f1525 100644
--- a/module/oop/goops/util.scm
+++ b/module/oop/goops/util.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -37,19 +37,6 @@
((memv (car l) (cdr l)) (car l))
(else (find-duplicate (cdr l)))))
-(begin-deprecated
- (define (top-level-env)
- (let ((mod (current-module)))
- (if mod
- (module-eval-closure mod)
- '())))
-
- (define (top-level-env? env)
- (or (null? env)
- (procedure? (car env))))
-
- (export top-level-env? top-level-env))
-
(define (map* fn . l) ; A map which accepts dotted lists (arg lists
(cond ; must be "isomorph"
((null? (car l)) '())
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index c1484cbed..069574a49 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -220,24 +220,22 @@
(define (port-transcoder port)
"Return the transcoder object associated with @var{port}, or @code{#f}
if the port has no transcoder."
- (cond ((port-encoding port)
- => (lambda (encoding)
- (make-transcoder
- encoding
- (native-eol-style)
- (case (port-conversion-strategy port)
- ((error) 'raise)
- ((substitute) 'replace)
- (else
- (assertion-violation 'port-transcoder
- "unsupported error handling mode"))))))
- (else
- #f)))
+ (and (textual-port? port)
+ ;; All textual ports have transcoders.
+ (make-transcoder
+ (port-encoding port)
+ (native-eol-style)
+ (case (port-conversion-strategy port)
+ ((error) 'raise)
+ ((substitute) 'replace)
+ (else
+ (assertion-violation 'port-transcoder
+ "unsupported error handling mode"))))))
(define (binary-port? port)
- "Returns @code{#t} if @var{port} does not have an associated encoding,
-@code{#f} otherwise."
- (not (port-encoding port)))
+ "Always returns @code{#t}, as all ports can be used for binary I/O in
+Guile."
+ (equal? (port-encoding port) "ISO-8859-1"))
(define (textual-port? port)
"Always returns @code{#t}, as all ports can be used for textual I/O in
diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm
index 7dab2dde9..094d65654 100644
--- a/module/scripts/disassemble.scm
+++ b/module/scripts/disassemble.scm
@@ -1,6 +1,6 @@
;;; Disassemble --- Disassemble .go files into something human-readable
-;; Copyright 2005, 2008, 2009, 2011 Free Software Foundation, Inc.
+;; Copyright 2005, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -36,7 +36,7 @@
(define (disassemble . files)
(for-each (lambda (file)
- (asm:disassemble (load-objcode file)))
+ (asm:disassemble (load-thunk-from-file file)))
files))
(define main disassemble)
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 4921a95d7..684a1254e 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -1,6 +1,6 @@
;;; srfi-18.scm --- Multithreading support
-;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009, 2010, 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -145,15 +145,15 @@
(check-arg-type procedure? handler "with-exception-handler")
(check-arg-type thunk? thunk "with-exception-handler")
(hashq-set! thread-exception-handlers ct (cons handler hl))
- (apply (@ (srfi srfi-34) with-exception-handler)
- (list (lambda (obj)
- (hashq-set! thread-exception-handlers ct hl)
- (handler obj))
- (lambda ()
- (call-with-values thunk
- (lambda res
- (hashq-set! thread-exception-handlers ct hl)
- (apply values res))))))))
+ ((@ (srfi srfi-34) with-exception-handler)
+ (lambda (obj)
+ (hashq-set! thread-exception-handlers ct hl)
+ (handler obj))
+ (lambda ()
+ (call-with-values thunk
+ (lambda res
+ (hashq-set! thread-exception-handlers ct hl)
+ (apply values res)))))))
(define (current-exception-handler)
(car (current-handler-stack)))
@@ -277,7 +277,7 @@
(define (thread-join! thread . args)
(define thread-join-inner!
(wrap (lambda ()
- (let ((v (apply join-thread (cons thread args)))
+ (let ((v (apply join-thread thread args))
(e (thread->exception thread)))
(if (and (= (length args) 1) (not v))
(raise join-timeout-exception))
@@ -320,12 +320,12 @@
(define mutex-lock-inner!
(wrap (lambda ()
(catch 'abandoned-mutex-error
- (lambda () (apply lock-mutex (cons mutex args)))
+ (lambda () (apply lock-mutex mutex args))
(lambda (key . args) (raise abandoned-mutex-exception))))))
(call/cc mutex-lock-inner!))
(define (mutex-unlock! mutex . args)
- (apply unlock-mutex (cons mutex args)))
+ (apply unlock-mutex mutex args))
;; CONDITION VARIABLES
;; These functions are all pass-thrus to the existing Guile implementations.
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index e4db6ffb3..01a71b8b9 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -192,10 +192,6 @@ which does the reverse. PRINT must name a user-defined object printer."
;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
(let ((ptr->obj (make-weak-value-hash-table 3000)))
(lambda (ptr)
- ;; XXX: We can't use `hash-create-handle!' +
- ;; `set-cdr!' here because the former would create a
- ;; weak-cdr pair but the latter wouldn't register a
- ;; disappearing link (see `scm_hash_fn_set_x'.)
(or (hash-ref ptr->obj ptr)
(let ((o (%wrap ptr)))
(hash-set! ptr->obj ptr o)
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 8ad00da08..a3e43fe18 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -1,6 +1,6 @@
;;; Repl commands
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -497,7 +497,7 @@ Disassemble a compiled procedure."
(define-meta-command (disassemble-file repl file)
"disassemble-file FILE
Disassemble a file."
- (guile:disassemble (load-objcode (->string file))))
+ (guile:disassemble (load-thunk-from-file (->string file))))
;;;
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
new file mode 100644
index 000000000..040b27433
--- /dev/null
+++ b/module/system/vm/elf.scm
@@ -0,0 +1,1255 @@
+;;; Guile ELF reader and writer
+
+;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm elf)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module (system base target)
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
+ #:export (has-elf-header?
+
+ make-elf elf?
+ elf-bytes elf-word-size elf-byte-order
+ elf-abi elf-type elf-machine-type
+ elf-entry elf-phoff elf-shoff elf-flags elf-ehsize
+ elf-phentsize elf-phnum elf-shentsize elf-shnum elf-shstrndx
+
+ (make-elf-segment* . make-elf-segment)
+ elf-segment?
+ elf-segment-type elf-segment-offset elf-segment-vaddr
+ elf-segment-paddr elf-segment-filesz elf-segment-memsz
+ elf-segment-flags elf-segment-align
+
+ (make-elf-section* . make-elf-section)
+ elf-section?
+ elf-section-name elf-section-type elf-section-flags
+ elf-section-addr elf-section-offset elf-section-size
+ elf-section-link elf-section-info elf-section-addralign
+ elf-section-entsize
+
+ make-elf-symbol elf-symbol?
+ elf-symbol-name elf-symbol-value elf-symbol-size
+ elf-symbol-info elf-symbol-other elf-symbol-shndx
+ elf-symbol-binding elf-symbol-type elf-symbol-visibility
+
+ SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA
+ SHT_HASH SHT_DYNAMIC SHT_NOTE SHT_NOBITS SHT_REL SHT_SHLIB
+ SHT_DYNSYM SHT_INIT_ARRAY SHT_FINI_ARRAY SHT_PREINIT_ARRAY
+ SHT_GROUP SHT_SYMTAB_SHNDX SHT_NUM SHT_LOOS SHT_HIOS
+ SHT_LOPROC SHT_HIPROC SHT_LOUSER SHT_HIUSER
+
+ SHF_WRITE SHF_ALLOC SHF_EXECINSTR SHF_MERGE SHF_STRINGS
+ SHF_INFO_LINK SHF_LINK_ORDER SHF_OS_NONCONFORMING SHF_GROUP
+ SHF_TLS
+
+ DT_NULL DT_NEEDED DT_PLTRELSZ DT_PLTGOT DT_HASH DT_STRTAB
+ DT_SYMTAB DT_RELA DT_RELASZ DT_RELAENT DT_STRSZ DT_SYMENT
+ DT_INIT DT_FINI DT_SONAME DT_RPATH DT_SYMBOLIC DT_REL
+ DT_RELSZ DT_RELENT DT_PLTREL DT_DEBUG DT_TEXTREL DT_JMPREL
+ DT_BIND_NOW DT_INIT_ARRAY DT_FINI_ARRAY DT_INIT_ARRAYSZ
+ DT_FINI_ARRAYSZ DT_RUNPATH DT_FLAGS DT_ENCODING
+ DT_PREINIT_ARRAY DT_PREINIT_ARRAYSZ DT_NUM DT_LOGUILE
+ DT_GUILE_GC_ROOT DT_GUILE_GC_ROOT_SZ DT_GUILE_ENTRY
+ DT_GUILE_RTL_VERSION DT_HIGUILE DT_LOOS DT_HIOS DT_LOPROC
+ DT_HIPROC
+
+ STB_LOCAL STB_GLOBAL STB_WEAK STB_NUM STB_LOOS STB_GNU
+ STB_HIOS STB_LOPROC STB_HIPROC
+
+ STT_NOTYPE STT_OBJECT STT_FUNC STT_SECTION STT_FILE
+ STT_COMMON STT_TLS STT_NUM STT_LOOS STT_GNU STT_HIOS
+ STT_LOPROC STT_HIPROC
+
+ STV_DEFAULT STV_INTERNAL STV_HIDDEN STV_PROTECTED
+
+ NT_GNU_ABI_TAG NT_GNU_HWCAP NT_GNU_BUILD_ID NT_GNU_GOLD_VERSION
+
+ parse-elf
+ elf-segment elf-segments
+ elf-section elf-sections elf-sections-by-name
+ elf-symbol-table-ref
+
+ parse-elf-note
+ elf-note-name elf-note-desc elf-note-type
+
+ (make-string-table . make-elf-string-table)
+ (string-table-intern . elf-string-table-intern)
+ (link-string-table . link-elf-string-table)
+
+ (make-reloc . make-elf-reloc)
+ (make-symbol . make-elf-symbol)
+
+ (make-object . make-elf-object)
+ (object? . elf-object?)
+ (object-section . elf-object-section)
+ (object-bv . elf-object-bv)
+ (object-relocs . elf-object-relocs)
+ (object-symbols . elf-object-symbols)
+
+ link-elf))
+
+;; #define EI_NIDENT 16
+
+;; typedef struct {
+;; unsigned char e_ident[EI_NIDENT];
+;; uint16_t e_type;
+;; uint16_t e_machine;
+;; uint32_t e_version;
+;; ElfN_Addr e_entry;
+;; ElfN_Off e_phoff;
+;; ElfN_Off e_shoff;
+;; uint32_t e_flags;
+;; uint16_t e_ehsize;
+;; uint16_t e_phentsize;
+;; uint16_t e_phnum;
+;; uint16_t e_shentsize;
+;; uint16_t e_shnum;
+;; uint16_t e_shstrndx;
+;; } ElfN_Ehdr;
+
+(define elf32-header-len 52)
+(define elf64-header-len 64)
+(define (elf-header-len word-size)
+ (case word-size
+ ((4) elf32-header-len)
+ ((8) elf64-header-len)
+ (else (error "invalid word size" word-size))))
+
+(define ELFCLASS32 1) ; 32-bit objects
+(define ELFCLASS64 2) ; 64-bit objects
+
+(define ELFDATA2LSB 1) ; 2's complement, little endian
+(define ELFDATA2MSB 2) ; 2's complement, big endian
+
+(define EV_CURRENT 1) ; Current version
+
+(define ELFOSABI_STANDALONE 255) ; Standalone (embedded) application
+
+(define ET_DYN 3) ; Shared object file
+
+;;
+;; Machine types
+;;
+;; Just a sampling of these values. We could include more, but the
+;; important thing is to recognize architectures for which we have a
+;; native compiler. Recognizing more common machine types is icing on
+;; the cake.
+;;
+(define EM_NONE 0) ; No machine
+(define EM_SPARC 2) ; SUN SPARC
+(define EM_386 3) ; Intel 80386
+(define EM_MIPS 8) ; MIPS R3000 big-endian
+(define EM_PPC 20) ; PowerPC
+(define EM_PPC64 21) ; PowerPC 64-bit
+(define EM_ARM 40) ; ARM
+(define EM_SH 42) ; Hitachi SH
+(define EM_SPARCV9 43) ; SPARC v9 64-bit
+(define EM_IA_64 50) ; Intel Merced
+(define EM_X86_64 62) ; AMD x86-64 architecture
+
+(define cpu-mapping (make-hash-table))
+(for-each (lambda (pair)
+ (hashq-set! cpu-mapping (car pair) (cdr pair)))
+ `((none . ,EM_NONE)
+ (sparc . ,EM_SPARC) ; FIXME: map 64-bit to SPARCV9 ?
+ (i386 . ,EM_386)
+ (mips . ,EM_MIPS)
+ (ppc . ,EM_PPC)
+ (ppc64 . ,EM_PPC64)
+ (arm . ,EM_ARM) ; FIXME: there are more arm cpu variants
+ (sh . ,EM_SH) ; FIXME: there are more sh cpu variants
+ (ia64 . ,EM_IA_64)
+ (x86_64 . ,EM_X86_64)))
+
+(define SHN_UNDEF 0)
+
+(define host-machine-type
+ (hashq-ref cpu-mapping
+ (string->symbol (car (string-split %host-type #\-)))
+ EM_NONE))
+
+(define host-word-size
+ (sizeof '*))
+
+(define host-byte-order
+ (native-endianness))
+
+(define (has-elf-header? bv)
+ (and
+ ;; e_ident
+ (>= (bytevector-length bv) 16)
+ (= (bytevector-u8-ref bv 0) #x7f)
+ (= (bytevector-u8-ref bv 1) (char->integer #\E))
+ (= (bytevector-u8-ref bv 2) (char->integer #\L))
+ (= (bytevector-u8-ref bv 3) (char->integer #\F))
+ (cond
+ ((= (bytevector-u8-ref bv 4) ELFCLASS32)
+ (>= (bytevector-length bv) elf32-header-len))
+ ((= (bytevector-u8-ref bv 4) ELFCLASS64)
+ (>= (bytevector-length bv) elf64-header-len))
+ (else #f))
+ (or (= (bytevector-u8-ref bv 5) ELFDATA2LSB)
+ (= (bytevector-u8-ref bv 5) ELFDATA2MSB))
+ (= (bytevector-u8-ref bv 6) EV_CURRENT)
+ ;; Look at ABI later.
+ (= (bytevector-u8-ref bv 8) 0) ; ABI version
+ ;; The rest of the e_ident is padding.
+
+ ;; e_version
+ (let ((byte-order (if (= (bytevector-u8-ref bv 5) ELFDATA2LSB)
+ (endianness little)
+ (endianness big))))
+ (= (bytevector-u32-ref bv 20 byte-order) EV_CURRENT))))
+
+(define-record-type <elf>
+ (make-elf bytes word-size byte-order abi type machine-type
+ entry phoff shoff flags ehsize
+ phentsize phnum shentsize shnum shstrndx)
+ elf?
+ (bytes elf-bytes)
+ (word-size elf-word-size)
+ (byte-order elf-byte-order)
+ (abi elf-abi)
+ (type elf-type)
+ (machine-type elf-machine-type)
+ (entry elf-entry)
+ (phoff elf-phoff)
+ (shoff elf-shoff)
+ (flags elf-flags)
+ (ehsize elf-ehsize)
+ (phentsize elf-phentsize)
+ (phnum elf-phnum)
+ (shentsize elf-shentsize)
+ (shnum elf-shnum)
+ (shstrndx elf-shstrndx))
+
+(define (parse-elf32 bv byte-order)
+ (make-elf bv 4 byte-order
+ (bytevector-u8-ref bv 7)
+ (bytevector-u16-ref bv 16 byte-order)
+ (bytevector-u16-ref bv 18 byte-order)
+ (bytevector-u32-ref bv 24 byte-order)
+ (bytevector-u32-ref bv 28 byte-order)
+ (bytevector-u32-ref bv 32 byte-order)
+ (bytevector-u32-ref bv 36 byte-order)
+ (bytevector-u16-ref bv 40 byte-order)
+ (bytevector-u16-ref bv 42 byte-order)
+ (bytevector-u16-ref bv 44 byte-order)
+ (bytevector-u16-ref bv 46 byte-order)
+ (bytevector-u16-ref bv 48 byte-order)
+ (bytevector-u16-ref bv 50 byte-order)))
+
+(define (write-elf-ident bv class data abi)
+ (bytevector-u8-set! bv 0 #x7f)
+ (bytevector-u8-set! bv 1 (char->integer #\E))
+ (bytevector-u8-set! bv 2 (char->integer #\L))
+ (bytevector-u8-set! bv 3 (char->integer #\F))
+ (bytevector-u8-set! bv 4 class)
+ (bytevector-u8-set! bv 5 data)
+ (bytevector-u8-set! bv 6 EV_CURRENT)
+ (bytevector-u8-set! bv 7 abi)
+ (bytevector-u8-set! bv 8 0) ; ABI version
+ (bytevector-u8-set! bv 9 0) ; Pad to 16 bytes.
+ (bytevector-u8-set! bv 10 0)
+ (bytevector-u8-set! bv 11 0)
+ (bytevector-u8-set! bv 12 0)
+ (bytevector-u8-set! bv 13 0)
+ (bytevector-u8-set! bv 14 0)
+ (bytevector-u8-set! bv 15 0))
+
+(define (write-elf32 bv byte-order abi type machine-type
+ entry phoff shoff flags ehsize phentsize phnum
+ shentsize shnum shstrndx)
+ (write-elf-ident bv ELFCLASS32
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ abi)
+ (bytevector-u16-set! bv 16 type byte-order)
+ (bytevector-u16-set! bv 18 machine-type byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u32-set! bv 24 entry byte-order)
+ (bytevector-u32-set! bv 28 phoff byte-order)
+ (bytevector-u32-set! bv 32 shoff byte-order)
+ (bytevector-u32-set! bv 36 flags byte-order)
+ (bytevector-u16-set! bv 40 ehsize byte-order)
+ (bytevector-u16-set! bv 42 phentsize byte-order)
+ (bytevector-u16-set! bv 44 phnum byte-order)
+ (bytevector-u16-set! bv 46 shentsize byte-order)
+ (bytevector-u16-set! bv 48 shnum byte-order)
+ (bytevector-u16-set! bv 50 shstrndx byte-order))
+
+(define (parse-elf64 bv byte-order)
+ (make-elf bv 8 byte-order
+ (bytevector-u8-ref bv 7)
+ (bytevector-u16-ref bv 16 byte-order)
+ (bytevector-u16-ref bv 18 byte-order)
+ (bytevector-u64-ref bv 24 byte-order)
+ (bytevector-u64-ref bv 32 byte-order)
+ (bytevector-u64-ref bv 40 byte-order)
+ (bytevector-u32-ref bv 48 byte-order)
+ (bytevector-u16-ref bv 52 byte-order)
+ (bytevector-u16-ref bv 54 byte-order)
+ (bytevector-u16-ref bv 56 byte-order)
+ (bytevector-u16-ref bv 58 byte-order)
+ (bytevector-u16-ref bv 60 byte-order)
+ (bytevector-u16-ref bv 62 byte-order)))
+
+(define (write-elf64 bv byte-order abi type machine-type
+ entry phoff shoff flags ehsize phentsize phnum
+ shentsize shnum shstrndx)
+ (write-elf-ident bv ELFCLASS64
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ abi)
+ (bytevector-u16-set! bv 16 type byte-order)
+ (bytevector-u16-set! bv 18 machine-type byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u64-set! bv 24 entry byte-order)
+ (bytevector-u64-set! bv 32 phoff byte-order)
+ (bytevector-u64-set! bv 40 shoff byte-order)
+ (bytevector-u32-set! bv 48 flags byte-order)
+ (bytevector-u16-set! bv 52 ehsize byte-order)
+ (bytevector-u16-set! bv 54 phentsize byte-order)
+ (bytevector-u16-set! bv 56 phnum byte-order)
+ (bytevector-u16-set! bv 58 shentsize byte-order)
+ (bytevector-u16-set! bv 60 shnum byte-order)
+ (bytevector-u16-set! bv 62 shstrndx byte-order))
+
+(define (parse-elf bv)
+ (cond
+ ((has-elf-header? bv)
+ (let ((class (bytevector-u8-ref bv 4))
+ (byte-order (let ((data (bytevector-u8-ref bv 5)))
+ (cond
+ ((= data ELFDATA2LSB) (endianness little))
+ ((= data ELFDATA2MSB) (endianness big))
+ (else (error "unhandled byte order" data))))))
+ (cond
+ ((= class ELFCLASS32) (parse-elf32 bv byte-order))
+ ((= class ELFCLASS64) (parse-elf64 bv byte-order))
+ (else (error "unhandled class" class)))))
+ (else
+ (error "Invalid ELF" bv))))
+
+(define* (write-elf-header bv #:key
+ (byte-order (target-endianness))
+ (word-size (target-word-size))
+ (abi ELFOSABI_STANDALONE)
+ (type ET_DYN)
+ (machine-type EM_NONE)
+ (entry 0)
+ (phoff (elf-header-len word-size))
+ (shoff -1)
+ (flags 0)
+ (ehsize (elf-header-len word-size))
+ (phentsize (elf-program-header-len word-size))
+ (phnum 0)
+ (shentsize (elf-section-header-len word-size))
+ (shnum 0)
+ (shstrndx SHN_UNDEF))
+ ((case word-size
+ ((4) write-elf32)
+ ((8) write-elf64)
+ (else (error "unknown word size" word-size)))
+ bv byte-order abi type machine-type entry phoff shoff
+ flags ehsize phentsize phnum shentsize shnum shstrndx))
+
+;;
+;; Segment types
+;;
+(define PT_NULL 0) ; Program header table entry unused
+(define PT_LOAD 1) ; Loadable program segment
+(define PT_DYNAMIC 2) ; Dynamic linking information
+(define PT_INTERP 3) ; Program interpreter
+(define PT_NOTE 4) ; Auxiliary information
+(define PT_SHLIB 5) ; Reserved
+(define PT_PHDR 6) ; Entry for header table itself
+(define PT_TLS 7) ; Thread-local storage segment
+(define PT_NUM 8) ; Number of defined types
+(define PT_LOOS #x60000000) ; Start of OS-specific
+(define PT_GNU_EH_FRAME #x6474e550) ; GCC .eh_frame_hdr segment
+(define PT_GNU_STACK #x6474e551) ; Indicates stack executability
+(define PT_GNU_RELRO #x6474e552) ; Read-only after relocation
+
+;;
+;; Segment flags
+;;
+(define PF_X (ash 1 0)) ; Segment is executable
+(define PF_W (ash 1 1)) ; Segment is writable
+(define PF_R (ash 1 2)) ; Segment is readable
+
+(define-record-type <elf-segment>
+ (make-elf-segment type offset vaddr paddr filesz memsz flags align)
+ elf-segment?
+ (type elf-segment-type)
+ (offset elf-segment-offset)
+ (vaddr elf-segment-vaddr)
+ (paddr elf-segment-paddr)
+ (filesz elf-segment-filesz)
+ (memsz elf-segment-memsz)
+ (flags elf-segment-flags)
+ (align elf-segment-align))
+
+(define* (make-elf-segment* #:key (type PT_LOAD) (offset 0) (vaddr 0)
+ (paddr 0) (filesz 0) (memsz filesz)
+ (flags (logior PF_W PF_R))
+ (align 8))
+ (make-elf-segment type offset vaddr paddr filesz memsz flags align))
+
+;; typedef struct {
+;; uint32_t p_type;
+;; Elf32_Off p_offset;
+;; Elf32_Addr p_vaddr;
+;; Elf32_Addr p_paddr;
+;; uint32_t p_filesz;
+;; uint32_t p_memsz;
+;; uint32_t p_flags;
+;; uint32_t p_align;
+;; } Elf32_Phdr;
+
+(define (parse-elf32-program-header bv offset byte-order)
+ (if (<= (+ offset 32) (bytevector-length bv))
+ (make-elf-segment (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u32-ref bv (+ offset 8) byte-order)
+ (bytevector-u32-ref bv (+ offset 12) byte-order)
+ (bytevector-u32-ref bv (+ offset 16) byte-order)
+ (bytevector-u32-ref bv (+ offset 20) byte-order)
+ (bytevector-u32-ref bv (+ offset 24) byte-order)
+ (bytevector-u32-ref bv (+ offset 28) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf32-program-header bv offset byte-order seg)
+ (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-segment-offset seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-segment-vaddr seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 12) (elf-segment-paddr seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 16) (elf-segment-filesz seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 20) (elf-segment-memsz seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 24) (elf-segment-flags seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 28) (elf-segment-align seg) byte-order))
+
+
+;; typedef struct {
+;; uint32_t p_type;
+;; uint32_t p_flags;
+;; Elf64_Off p_offset;
+;; Elf64_Addr p_vaddr;
+;; Elf64_Addr p_paddr;
+;; uint64_t p_filesz;
+;; uint64_t p_memsz;
+;; uint64_t p_align;
+;; } Elf64_Phdr;
+
+;; NB: position of `flags' is different!
+
+(define (parse-elf64-program-header bv offset byte-order)
+ (if (<= (+ offset 56) (bytevector-length bv))
+ (make-elf-segment (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u64-ref bv (+ offset 8) byte-order)
+ (bytevector-u64-ref bv (+ offset 16) byte-order)
+ (bytevector-u64-ref bv (+ offset 24) byte-order)
+ (bytevector-u64-ref bv (+ offset 32) byte-order)
+ (bytevector-u64-ref bv (+ offset 40) byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u64-ref bv (+ offset 48) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf64-program-header bv offset byte-order seg)
+ (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-segment-offset seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-segment-vaddr seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 24) (elf-segment-paddr seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 32) (elf-segment-filesz seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 40) (elf-segment-memsz seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-segment-flags seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 48) (elf-segment-align seg) byte-order))
+
+(define (write-elf-program-header bv offset byte-order word-size seg)
+ ((case word-size
+ ((4) write-elf32-program-header)
+ ((8) write-elf64-program-header)
+ (else (error "invalid word size" word-size)))
+ bv offset byte-order seg))
+
+(define (elf-program-header-len word-size)
+ (case word-size
+ ((4) 32)
+ ((8) 56)
+ (else (error "bad word size" word-size))))
+
+(define (elf-segment elf n)
+ (if (not (< -1 n (elf-phnum elf)))
+ (error "bad segment number" n))
+ ((case (elf-word-size elf)
+ ((4) parse-elf32-program-header)
+ ((8) parse-elf64-program-header)
+ (else (error "unhandled pointer size")))
+ (elf-bytes elf)
+ (+ (elf-phoff elf) (* n (elf-phentsize elf)))
+ (elf-byte-order elf)))
+
+(define (elf-segments elf)
+ (let lp ((n (elf-phnum elf)) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n) (cons (elf-segment elf (1- n)) out)))))
+
+(define-record-type <elf-section>
+ (make-elf-section name type flags addr offset size link info addralign entsize)
+ elf-section?
+ (name elf-section-name)
+ (type elf-section-type)
+ (flags elf-section-flags)
+ (addr elf-section-addr)
+ (offset elf-section-offset)
+ (size elf-section-size)
+ (link elf-section-link)
+ (info elf-section-info)
+ (addralign elf-section-addralign)
+ (entsize elf-section-entsize))
+
+(define* (make-elf-section* #:key (name 0) (type SHT_PROGBITS)
+ (flags SHF_ALLOC) (addr 0) (offset 0) (size 0)
+ (link 0) (info 0) (addralign 8) (entsize 0))
+ (make-elf-section name type flags addr offset size link info addralign
+ entsize))
+
+;; typedef struct {
+;; uint32_t sh_name;
+;; uint32_t sh_type;
+;; uint32_t sh_flags;
+;; Elf32_Addr sh_addr;
+;; Elf32_Off sh_offset;
+;; uint32_t sh_size;
+;; uint32_t sh_link;
+;; uint32_t sh_info;
+;; uint32_t sh_addralign;
+;; uint32_t sh_entsize;
+;; } Elf32_Shdr;
+
+(define (parse-elf32-section-header bv offset byte-order)
+ (if (<= (+ offset 40) (bytevector-length bv))
+ (make-elf-section (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u32-ref bv (+ offset 8) byte-order)
+ (bytevector-u32-ref bv (+ offset 12) byte-order)
+ (bytevector-u32-ref bv (+ offset 16) byte-order)
+ (bytevector-u32-ref bv (+ offset 20) byte-order)
+ (bytevector-u32-ref bv (+ offset 24) byte-order)
+ (bytevector-u32-ref bv (+ offset 28) byte-order)
+ (bytevector-u32-ref bv (+ offset 32) byte-order)
+ (bytevector-u32-ref bv (+ offset 36) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf32-section-header bv offset byte-order sec)
+ (bytevector-u32-set! bv offset (elf-section-name sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-section-flags sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 12) (elf-section-addr sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 16) (elf-section-offset sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 20) (elf-section-size sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 24) (elf-section-link sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 28) (elf-section-info sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 32) (elf-section-addralign sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 36) (elf-section-entsize sec) byte-order))
+
+
+;; typedef struct {
+;; uint32_t sh_name;
+;; uint32_t sh_type;
+;; uint64_t sh_flags;
+;; Elf64_Addr sh_addr;
+;; Elf64_Off sh_offset;
+;; uint64_t sh_size;
+;; uint32_t sh_link;
+;; uint32_t sh_info;
+;; uint64_t sh_addralign;
+;; uint64_t sh_entsize;
+;; } Elf64_Shdr;
+
+(define (elf-section-header-len word-size)
+ (case word-size
+ ((4) 40)
+ ((8) 64)
+ (else (error "bad word size" word-size))))
+
+(define (parse-elf64-section-header bv offset byte-order)
+ (if (<= (+ offset 64) (bytevector-length bv))
+ (make-elf-section (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u64-ref bv (+ offset 8) byte-order)
+ (bytevector-u64-ref bv (+ offset 16) byte-order)
+ (bytevector-u64-ref bv (+ offset 24) byte-order)
+ (bytevector-u64-ref bv (+ offset 32) byte-order)
+ (bytevector-u32-ref bv (+ offset 40) byte-order)
+ (bytevector-u32-ref bv (+ offset 44) byte-order)
+ (bytevector-u64-ref bv (+ offset 48) byte-order)
+ (bytevector-u64-ref bv (+ offset 56) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf64-section-header bv offset byte-order sec)
+ (bytevector-u32-set! bv offset (elf-section-name sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-section-flags sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-section-addr sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 24) (elf-section-offset sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 32) (elf-section-size sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 40) (elf-section-link sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 44) (elf-section-info sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 48) (elf-section-addralign sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 56) (elf-section-entsize sec) byte-order))
+
+(define (elf-section elf n)
+ (if (not (< -1 n (elf-shnum elf)))
+ (error "bad section number" n))
+ ((case (elf-word-size elf)
+ ((4) parse-elf32-section-header)
+ ((8) parse-elf64-section-header)
+ (else (error "unhandled pointer size")))
+ (elf-bytes elf)
+ (+ (elf-shoff elf) (* n (elf-shentsize elf)))
+ (elf-byte-order elf)))
+
+(define (write-elf-section-header bv offset byte-order word-size sec)
+ ((case word-size
+ ((4) write-elf32-section-header)
+ ((8) write-elf64-section-header)
+ (else (error "invalid word size" word-size)))
+ bv offset byte-order sec))
+
+(define (elf-sections elf)
+ (let lp ((n (elf-shnum elf)) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n) (cons (elf-section elf (1- n)) out)))))
+
+;;
+;; Section Types
+;;
+(define SHT_NULL 0) ; Section header table entry unused
+(define SHT_PROGBITS 1) ; Program data
+(define SHT_SYMTAB 2) ; Symbol table
+(define SHT_STRTAB 3) ; String table
+(define SHT_RELA 4) ; Relocation entries with addends
+(define SHT_HASH 5) ; Symbol hash table
+(define SHT_DYNAMIC 6) ; Dynamic linking information
+(define SHT_NOTE 7) ; Notes
+(define SHT_NOBITS 8) ; Program space with no data (bss)
+(define SHT_REL 9) ; Relocation entries, no addends
+(define SHT_SHLIB 10) ; Reserved
+(define SHT_DYNSYM 11) ; Dynamic linker symbol table
+(define SHT_INIT_ARRAY 14) ; Array of constructors
+(define SHT_FINI_ARRAY 15) ; Array of destructors
+(define SHT_PREINIT_ARRAY 16) ; Array of pre-constructors
+(define SHT_GROUP 17) ; Section group
+(define SHT_SYMTAB_SHNDX 18) ; Extended section indeces
+(define SHT_NUM 19) ; Number of defined types.
+(define SHT_LOOS #x60000000) ; Start OS-specific.
+(define SHT_HIOS #x6fffffff) ; End OS-specific type
+(define SHT_LOPROC #x70000000) ; Start of processor-specific
+(define SHT_HIPROC #x7fffffff) ; End of processor-specific
+(define SHT_LOUSER #x80000000) ; Start of application-specific
+(define SHT_HIUSER #x8fffffff) ; End of application-specific
+
+;;
+;; Section Flags
+;;
+(define SHF_WRITE (ash 1 0)) ; Writable
+(define SHF_ALLOC (ash 1 1)) ; Occupies memory during execution
+(define SHF_EXECINSTR (ash 1 2)) ; Executable
+(define SHF_MERGE (ash 1 4)) ; Might be merged
+(define SHF_STRINGS (ash 1 5)) ; Contains nul-terminated strings
+(define SHF_INFO_LINK (ash 1 6)) ; `sh_info' contains SHT index
+(define SHF_LINK_ORDER (ash 1 7)) ; Preserve order after combining
+(define SHF_OS_NONCONFORMING (ash 1 8)) ; Non-standard OS specific handling required
+(define SHF_GROUP (ash 1 9)) ; Section is member of a group.
+(define SHF_TLS (ash 1 10)) ; Section hold thread-local data.
+
+;;
+;; Dynamic entry types. The DT_GUILE types are non-standard.
+;;
+(define DT_NULL 0) ; Marks end of dynamic section
+(define DT_NEEDED 1) ; Name of needed library
+(define DT_PLTRELSZ 2) ; Size in bytes of PLT relocs
+(define DT_PLTGOT 3) ; Processor defined value
+(define DT_HASH 4) ; Address of symbol hash table
+(define DT_STRTAB 5) ; Address of string table
+(define DT_SYMTAB 6) ; Address of symbol table
+(define DT_RELA 7) ; Address of Rela relocs
+(define DT_RELASZ 8) ; Total size of Rela relocs
+(define DT_RELAENT 9) ; Size of one Rela reloc
+(define DT_STRSZ 10) ; Size of string table
+(define DT_SYMENT 11) ; Size of one symbol table entry
+(define DT_INIT 12) ; Address of init function
+(define DT_FINI 13) ; Address of termination function
+(define DT_SONAME 14) ; Name of shared object
+(define DT_RPATH 15) ; Library search path (deprecated)
+(define DT_SYMBOLIC 16) ; Start symbol search here
+(define DT_REL 17) ; Address of Rel relocs
+(define DT_RELSZ 18) ; Total size of Rel relocs
+(define DT_RELENT 19) ; Size of one Rel reloc
+(define DT_PLTREL 20) ; Type of reloc in PLT
+(define DT_DEBUG 21) ; For debugging ; unspecified
+(define DT_TEXTREL 22) ; Reloc might modify .text
+(define DT_JMPREL 23) ; Address of PLT relocs
+(define DT_BIND_NOW 24) ; Process relocations of object
+(define DT_INIT_ARRAY 25) ; Array with addresses of init fct
+(define DT_FINI_ARRAY 26) ; Array with addresses of fini fct
+(define DT_INIT_ARRAYSZ 27) ; Size in bytes of DT_INIT_ARRAY
+(define DT_FINI_ARRAYSZ 28) ; Size in bytes of DT_FINI_ARRAY
+(define DT_RUNPATH 29) ; Library search path
+(define DT_FLAGS 30) ; Flags for the object being loaded
+(define DT_ENCODING 32) ; Start of encoded range
+(define DT_PREINIT_ARRAY 32) ; Array with addresses of preinit fc
+(define DT_PREINIT_ARRAYSZ 33) ; size in bytes of DT_PREINIT_ARRAY
+(define DT_NUM 34) ; Number used
+(define DT_LOGUILE #x37146000) ; Start of Guile-specific
+(define DT_GUILE_GC_ROOT #x37146000) ; Offset of GC roots
+(define DT_GUILE_GC_ROOT_SZ #x37146001) ; Size in machine words of GC roots
+(define DT_GUILE_ENTRY #x37146002) ; Address of entry thunk
+(define DT_GUILE_RTL_VERSION #x37146003); Bytecode version
+(define DT_HIGUILE #x37146fff) ; End of Guile-specific
+(define DT_LOOS #x6000000d) ; Start of OS-specific
+(define DT_HIOS #x6ffff000) ; End of OS-specific
+(define DT_LOPROC #x70000000) ; Start of processor-specific
+(define DT_HIPROC #x7fffffff) ; End of processor-specific
+
+
+(define (string-table-ref bv offset)
+ (let lp ((end offset))
+ (if (zero? (bytevector-u8-ref bv end))
+ (let ((out (make-bytevector (- end offset))))
+ (bytevector-copy! bv offset out 0 (- end offset))
+ (utf8->string out))
+ (lp (1+ end)))))
+
+(define (elf-sections-by-name elf)
+ (let* ((sections (elf-sections elf))
+ (off (elf-section-offset (list-ref sections (elf-shstrndx elf)))))
+ (map (lambda (section)
+ (cons (string-table-ref (elf-bytes elf)
+ (+ off (elf-section-name section)))
+ section))
+ sections)))
+
+(define-record-type <elf-symbol>
+ (make-elf-symbol name value size info other shndx)
+ elf-symbol?
+ (name elf-symbol-name)
+ (value elf-symbol-value)
+ (size elf-symbol-size)
+ (info elf-symbol-info)
+ (other elf-symbol-other)
+ (shndx elf-symbol-shndx))
+
+;; typedef struct {
+;; uint32_t st_name;
+;; Elf32_Addr st_value;
+;; uint32_t st_size;
+;; unsigned char st_info;
+;; unsigned char st_other;
+;; uint16_t st_shndx;
+;; } Elf32_Sym;
+
+(define (parse-elf32-symbol bv offset stroff byte-order)
+ (if (<= (+ offset 16) (bytevector-length bv))
+ (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
+ (if stroff
+ (string-table-ref bv (+ stroff name))
+ name))
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u32-ref bv (+ offset 8) byte-order)
+ (bytevector-u8-ref bv (+ offset 12))
+ (bytevector-u8-ref bv (+ offset 13))
+ (bytevector-u16-ref bv (+ offset 14) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+;; typedef struct {
+;; uint32_t st_name;
+;; unsigned char st_info;
+;; unsigned char st_other;
+;; uint16_t st_shndx;
+;; Elf64_Addr st_value;
+;; uint64_t st_size;
+;; } Elf64_Sym;
+
+(define (parse-elf64-symbol bv offset stroff byte-order)
+ (if (<= (+ offset 24) (bytevector-length bv))
+ (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
+ (if stroff
+ (string-table-ref bv (+ stroff name))
+ name))
+ (bytevector-u64-ref bv (+ offset 8) byte-order)
+ (bytevector-u64-ref bv (+ offset 16) byte-order)
+ (bytevector-u8-ref bv (+ offset 4))
+ (bytevector-u8-ref bv (+ offset 5))
+ (bytevector-u16-ref bv (+ offset 6) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define* (elf-symbol-table-ref elf section n #:optional strtab)
+ (let ((bv (elf-bytes elf))
+ (byte-order (elf-byte-order elf))
+ (stroff (and strtab (elf-section-offset strtab)))
+ (base (elf-section-offset section))
+ (len (elf-section-size section))
+ (entsize (elf-section-entsize section)))
+ (unless (<= (* (1+ n) entsize) len)
+ (error "out of range symbol table access" section n))
+ (case (elf-word-size elf)
+ ((4)
+ (unless (<= 16 entsize)
+ (error "bad entsize for symbol table" section))
+ (parse-elf32-symbol bv (+ base (* n entsize)) stroff byte-order))
+ ((8)
+ (unless (<= 24 entsize)
+ (error "bad entsize for symbol table" section))
+ (parse-elf64-symbol bv (+ base (* n entsize)) stroff byte-order))
+ (else (error "bad word size" elf)))))
+
+;; Legal values for ST_BIND subfield of st_info (symbol binding).
+
+(define STB_LOCAL 0) ; Local symbol
+(define STB_GLOBAL 1) ; Global symbol
+(define STB_WEAK 2) ; Weak symbol
+(define STB_NUM 3) ; Number of defined types.
+(define STB_LOOS 10) ; Start of OS-specific
+(define STB_GNU_UNIQUE 10) ; Unique symbol.
+(define STB_HIOS 12) ; End of OS-specific
+(define STB_LOPROC 13) ; Start of processor-specific
+(define STB_HIPROC 15) ; End of processor-specific
+
+;; Legal values for ST_TYPE subfield of st_info (symbol type).
+
+(define STT_NOTYPE 0) ; Symbol type is unspecified
+(define STT_OBJECT 1) ; Symbol is a data object
+(define STT_FUNC 2) ; Symbol is a code object
+(define STT_SECTION 3) ; Symbol associated with a section
+(define STT_FILE 4) ; Symbol's name is file name
+(define STT_COMMON 5) ; Symbol is a common data object
+(define STT_TLS 6) ; Symbol is thread-local data objec
+(define STT_NUM 7) ; Number of defined types.
+(define STT_LOOS 10) ; Start of OS-specific
+(define STT_GNU_IFUNC 10) ; Symbol is indirect code object
+(define STT_HIOS 12) ; End of OS-specific
+(define STT_LOPROC 13) ; Start of processor-specific
+(define STT_HIPROC 15) ; End of processor-specific
+
+;; Symbol visibility specification encoded in the st_other field.
+
+(define STV_DEFAULT 0) ; Default symbol visibility rules
+(define STV_INTERNAL 1) ; Processor specific hidden class
+(define STV_HIDDEN 2) ; Sym unavailable in other modules
+(define STV_PROTECTED 3) ; Not preemptible, not exported
+
+(define (elf-symbol-binding sym)
+ (ash (elf-symbol-info sym) -4))
+
+(define (elf-symbol-type sym)
+ (logand (elf-symbol-info sym) #xf))
+
+(define (elf-symbol-visibility sym)
+ (logand (elf-symbol-other sym) #x3))
+
+(define NT_GNU_ABI_TAG 1)
+(define NT_GNU_HWCAP 2)
+(define NT_GNU_BUILD_ID 3)
+(define NT_GNU_GOLD_VERSION 4)
+
+(define-record-type <elf-note>
+ (make-elf-note name desc type)
+ elf-note?
+ (name elf-note-name)
+ (desc elf-note-desc)
+ (type elf-note-type))
+
+(define (parse-elf-note elf section)
+ (let ((bv (elf-bytes elf))
+ (byte-order (elf-byte-order elf))
+ (offset (elf-section-offset section)))
+ (unless (<= (+ offset 12) (bytevector-length bv))
+ (error "corrupt ELF (offset out of range)" offset))
+ (let ((namesz (bytevector-u32-ref bv offset byte-order))
+ (descsz (bytevector-u32-ref bv (+ offset 4) byte-order))
+ (type (bytevector-u32-ref bv (+ offset 8) byte-order)))
+ (unless (<= (+ offset 12 namesz descsz) (bytevector-length bv))
+ (error "corrupt ELF (offset out of range)" offset))
+ (let ((name (make-bytevector (1- namesz)))
+ (desc (make-bytevector descsz)))
+ (bytevector-copy! bv (+ offset 12) name 0 (1- namesz))
+ (bytevector-copy! bv (+ offset 12 namesz) desc 0 descsz)
+ (make-elf-note (utf8->string name) desc type)))))
+
+
+
+
+;;;
+;;; All of that was the parser. Now, on to a linker.
+;;;
+
+;; A relocation records a reference to a symbol. When the symbol is
+;; resolved to an address, the reloc location will be updated to point
+;; to the address.
+;;
+;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes.
+;; Rel32/4 is a relative signed offset in 32-bit units. Either can have
+;; an arbitrary addend as well.
+;;
+(define-record-type <reloc>
+ (make-reloc type loc addend symbol)
+ reloc?
+ (type reloc-type) ;; rel32/4, abs32/1, abs64/1
+ (loc reloc-loc)
+ (addend reloc-addend)
+ (symbol reloc-symbol))
+
+;; A symbol is an association between a name and an address. The
+;; address is always in regard to some particular address space. When
+;; objects come into the linker, their symbols live in the object
+;; address space. When the objects are allocated into ELF segments, the
+;; symbols will be relocated into memory address space, corresponding to
+;; the position the ELF will be loaded at.
+;;
+(define-record-type <symbol>
+ (make-symbol name address)
+ symbol?
+ (name symbol-name)
+ (address symbol-address))
+
+(define-record-type <object>
+ (make-object section bv relocs symbols)
+ object?
+ (section object-section)
+ (bv object-bv)
+ (relocs object-relocs)
+ (symbols object-symbols))
+
+(define (make-string-table)
+ '(("" 0 #vu8())))
+
+(define (string-table-length table)
+ (let ((last (car table)))
+ ;; The + 1 is for the trailing NUL byte.
+ (+ (cadr last) (bytevector-length (caddr last)) 1)))
+
+(define (string-table-intern table str)
+ (cond
+ ((assoc str table)
+ => (lambda (ent)
+ (values table (cadr ent))))
+ (else
+ (let* ((next (string-table-length table)))
+ (values (cons (list str next (string->utf8 str))
+ table)
+ next)))))
+
+(define (link-string-table table)
+ (let ((out (make-bytevector (string-table-length table) 0)))
+ (for-each
+ (lambda (ent)
+ (let ((bytes (caddr ent)))
+ (bytevector-copy! bytes 0 out (cadr ent) (bytevector-length bytes))))
+ table)
+ out))
+
+(define (segment-kind section)
+ (let ((flags (elf-section-flags section)))
+ (cons (cond
+ ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
+ ((zero? (logand SHF_ALLOC flags)) PT_NOTE)
+ (else PT_LOAD))
+ (logior (if (zero? (logand SHF_ALLOC flags))
+ 0
+ PF_R)
+ (if (zero? (logand SHF_EXECINSTR flags))
+ 0
+ PF_X)
+ (if (zero? (logand SHF_WRITE flags))
+ 0
+ PF_W)))))
+
+(define (group-by-cars ls)
+ (let lp ((in ls) (k #f) (group #f) (out '()))
+ (cond
+ ((null? in)
+ (reverse!
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))
+ ((and group (equal? k (caar in)))
+ (lp (cdr in) k (cons (cdar in) group) out))
+ (else
+ (lp (cdr in) (caar in) (list (cdar in))
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out))))))
+
+(define (collate-objects-into-segments objects)
+ (group-by-cars
+ (stable-sort!
+ (map (lambda (o)
+ (cons (segment-kind (object-section o)) o))
+ objects)
+ (lambda (x y)
+ (let ((x-type (caar x)) (y-type (caar y))
+ (x-flags (cdar x)) (y-flags (cdar y))
+ (x-section (object-section (cdr x)))
+ (y-section (object-section (cdr y))))
+ (cond
+ ((not (equal? x-flags y-flags))
+ (< x-flags y-flags))
+ ((not (equal? x-type y-type))
+ (< x-type y-type))
+ ((not (equal? (elf-section-type x-section)
+ (elf-section-type y-section)))
+ (cond
+ ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
+ ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
+ (else (< (elf-section-type x-section)
+ (elf-section-type y-section)))))
+ (else
+ (< (elf-section-size x-section)
+ (elf-section-size y-section)))))))))
+
+(define (align address alignment)
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment)))
+
+(define (fold1 proc ls s0)
+ (let lp ((ls ls) (s0 s0))
+ (if (null? ls)
+ s0
+ (lp (cdr ls) (proc (car ls) s0)))))
+
+(define (fold2 proc ls s0 s1)
+ (let lp ((ls ls) (s0 s0) (s1 s1))
+ (if (null? ls)
+ (values s0 s1)
+ (receive (s0 s1) (proc (car ls) s0 s1)
+ (lp (cdr ls) s0 s1)))))
+
+(define (fold4 proc ls s0 s1 s2 s3)
+ (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2) (s3 s3))
+ (if (null? ls)
+ (values s0 s1 s2 s3)
+ (receive (s0 s1 s2 s3) (proc (car ls) s0 s1 s2 s3)
+ (lp (cdr ls) s0 s1 s2 s3)))))
+
+(define (fold5 proc ls s0 s1 s2 s3 s4)
+ (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2) (s3 s3) (s4 s4))
+ (if (null? ls)
+ (values s0 s1 s2 s3 s4)
+ (receive (s0 s1 s2 s3 s4) (proc (car ls) s0 s1 s2 s3 s4)
+ (lp (cdr ls) s0 s1 s2 s3 s4)))))
+
+(define (relocate-section-header sec fileaddr memaddr)
+ (make-elf-section (elf-section-name sec) (elf-section-type sec)
+ (elf-section-flags sec) memaddr
+ fileaddr (elf-section-size sec)
+ (elf-section-link sec) (elf-section-info sec)
+ (elf-section-addralign sec) (elf-section-entsize sec)))
+
+(define *page-size* 4096)
+
+;; Adds object symbols to global table, relocating them from object
+;; address space to memory address space.
+(define (add-symbols symbols offset symtab)
+ (fold1 (lambda (symbol symtab)
+ (let ((name (symbol-name symbol))
+ (addr (symbol-address symbol)))
+ (vhash-consq name (make-symbol name (+ addr offset)) symtab)))
+ symbols
+ symtab))
+
+(define (alloc-segment type flags objects fileaddr memaddr symtab alignment)
+ (let* ((loadable? (not (zero? flags)))
+ (alignment (fold1 (lambda (o alignment)
+ (lcm (elf-section-addralign (object-section o))
+ alignment))
+ objects
+ alignment))
+ (fileaddr (align fileaddr alignment))
+ (memaddr (align memaddr alignment)))
+ (receive (objects fileend memend symtab)
+ (fold4 (lambda (o out fileaddr memaddr symtab)
+ (let* ((section (object-section o))
+ (fileaddr
+ (if (= (elf-section-type section) SHT_NOBITS)
+ fileaddr
+ (align fileaddr (elf-section-addralign section))))
+ (memaddr
+ (align memaddr (elf-section-addralign section))))
+ (values
+ (cons (make-object (relocate-section-header section fileaddr
+ memaddr)
+ (object-bv o)
+ (object-relocs o)
+ (object-symbols o))
+ out)
+ (if (= (elf-section-type section) SHT_NOBITS)
+ fileaddr
+ (+ fileaddr (elf-section-size section)))
+ (+ memaddr (elf-section-size section))
+ (add-symbols (object-symbols o) memaddr symtab))))
+ objects '() fileaddr memaddr symtab)
+ (values
+ (make-elf-segment* #:type type #:offset fileaddr
+ #:vaddr (if loadable? memaddr 0)
+ #:filesz (- fileend fileaddr)
+ #:memsz (if loadable? (- memend memaddr) 0)
+ #:flags flags #:align alignment)
+ (reverse objects)
+ symtab))))
+
+(define (process-reloc reloc bv file-offset mem-offset symtab endianness)
+ (let ((ent (vhash-assq (reloc-symbol reloc) symtab)))
+ (unless ent
+ (error "Undefined symbol" (reloc-symbol reloc)))
+ (let* ((file-loc (+ (reloc-loc reloc) file-offset))
+ (mem-loc (+ (reloc-loc reloc) mem-offset))
+ (addr (symbol-address (cdr ent))))
+ (case (reloc-type reloc)
+ ((rel32/4)
+ (let ((diff (- addr mem-loc)))
+ (unless (zero? (modulo diff 4))
+ (error "Bad offset" reloc symbol mem-offset))
+ (bytevector-s32-set! bv file-loc
+ (+ (/ diff 4) (reloc-addend reloc))
+ endianness)))
+ ((abs32/1)
+ (bytevector-u32-set! bv file-loc addr endianness))
+ ((abs64/1)
+ (bytevector-u64-set! bv file-loc addr endianness))
+ (else
+ (error "bad reloc type" reloc))))))
+
+(define (write-object bv o symtab endianness)
+ (let* ((section (object-section o))
+ (offset (elf-section-offset section))
+ (addr (elf-section-addr section))
+ (len (elf-section-size section))
+ (bytes (object-bv o))
+ (relocs (object-relocs o)))
+ (if (not (= (elf-section-type section) SHT_NOBITS))
+ (begin
+ (if (not (= (elf-section-size section) (bytevector-length bytes)))
+ (error "unexpected length" section bytes))
+ (bytevector-copy! bytes 0 bv offset len)
+ (for-each (lambda (reloc)
+ (process-reloc reloc bv offset addr symtab endianness))
+ relocs)))))
+
+(define (compute-sections-by-name seglists)
+ (let lp ((in (apply append (map cdr seglists)))
+ (n 1) (out '()) (shstrtab #f))
+ (if (null? in)
+ (fold1 (lambda (x tail)
+ (cond
+ ((false-if-exception
+ (string-table-ref shstrtab (car x)))
+ => (lambda (str) (acons str (cdr x) tail)))
+ (else tail)))
+ out '())
+ (let* ((section (object-section (car in)))
+ (bv (object-bv (car in)))
+ (name (elf-section-name section)))
+ (lp (cdr in) (1+ n) (acons name n out)
+ (or shstrtab
+ (and (= (elf-section-type section) SHT_STRTAB)
+ (equal? (false-if-exception
+ (string-table-ref bv name))
+ ".shstrtab")
+ bv)))))))
+
+;; Given a list of section-header/bytevector pairs, collate the sections
+;; into segments, allocate the segments, allocate the ELF bytevector,
+;; and write the segments into the bytevector, relocating as we go.
+;;
+(define* (link-elf objects #:key
+ (page-aligned? #t)
+ (endianness (target-endianness))
+ (word-size (target-word-size)))
+ (let* ((seglists (collate-objects-into-segments objects))
+ (sections-by-name (compute-sections-by-name seglists))
+ (nsegments (length seglists))
+ (nsections (1+ (length objects))) ;; 1+ for the first reserved entry.
+ (program-headers-offset (elf-header-len word-size))
+ (fileaddr (+ program-headers-offset
+ (* nsegments (elf-program-header-len word-size))))
+ (memaddr 0))
+ (receive (out fileend memend symtab _)
+ (fold5
+ (lambda (x out fileaddr memaddr symtab prev-flags)
+ (let ((type (caar x))
+ (flags (cdar x))
+ (objects (cdr x)))
+ (receive (segment objects symtab)
+ (alloc-segment type flags objects fileaddr memaddr symtab
+ (if (and page-aligned?
+ (not (= flags prev-flags)))
+ *page-size*
+ 8))
+ (values
+ (cons (cons segment objects) out)
+ (+ (elf-segment-offset segment) (elf-segment-filesz segment))
+ (if (zero? (elf-segment-memsz segment))
+ memaddr
+ (+ (elf-segment-vaddr segment)
+ (elf-segment-memsz segment)))
+ symtab
+ flags))))
+ seglists '() fileaddr memaddr vlist-null 0)
+ (let* ((out (reverse! out))
+ (section-table-offset (+ (align fileend word-size)))
+ (fileend (+ section-table-offset
+ (* nsections (elf-section-header-len word-size))))
+ (bv (make-bytevector fileend 0)))
+ (write-elf-header bv #:byte-order endianness #:word-size word-size
+ #:phoff program-headers-offset #:phnum nsegments
+ #:shoff section-table-offset #:shnum nsections
+ #:shstrndx (or (assoc-ref sections-by-name ".shstrtab")
+ SHN_UNDEF))
+ (write-elf-section-header bv section-table-offset
+ endianness word-size
+ (make-elf-section* #:type SHT_NULL #:flags 0
+ #:addralign 0))
+ (fold2 (lambda (x phidx shidx)
+ (write-elf-program-header
+ bv (+ program-headers-offset
+ (* (elf-program-header-len word-size) phidx))
+ endianness word-size (car x))
+ (values
+ (1+ phidx)
+ (fold1 (lambda (o shidx)
+ (write-object bv o symtab endianness)
+ (write-elf-section-header
+ bv (+ section-table-offset
+ (* (elf-section-header-len word-size) shidx))
+ endianness word-size (object-section o))
+ (1+ shidx))
+ (cdr x) shidx)))
+ out 0 1)
+ bv))))
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index 966f34585..f939a5551 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -1,6 +1,6 @@
;;; Guile VM object code
-;; Copyright (C) 2001, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010, 2012 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -21,7 +21,7 @@
(define-module (system vm objcode)
#:export (objcode? objcode-meta
bytecode->objcode objcode->bytecode
- load-objcode write-objcode
+ load-thunk-from-file load-thunk-from-memory
word-size byte-order))
(load-extension (string-append "libguile-" (effective-version))
diff --git a/module/web/server.scm b/module/web/server.scm
index 54ab9e335..affc2e6b6 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -164,11 +164,13 @@ values."
#:post-error (lambda _ (values #f #f #f))))
(define (extend-response r k v . additional)
+ (define (extend-alist alist k v)
+ (let ((pair (assq k alist)))
+ (acons k v (if pair (delq pair alist) alist))))
(let ((r (build-response #:version (response-version r)
#:code (response-code r)
#:headers
- (assoc-set! (copy-tree (response-headers r))
- k v)
+ (extend-alist (response-headers r) k v)
#:port (response-port r))))
(if (null? additional)
r