diff options
Diffstat (limited to 'module')
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 |