[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-148-g663c587
|
From: |
BT Templeton |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-148-g663c587 |
|
Date: |
Mon, 05 Mar 2012 23:35:07 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=663c5875f516ae9b36c6100dddd328de4c115147
The branch, master has been updated
via 663c5875f516ae9b36c6100dddd328de4c115147 (commit)
via 5ddd9645c94f339f8795bf9b3ece8d518a8de004 (commit)
via eaeda0d550c513f4d134304d9adda28e1d65a23b (commit)
via 5199c059e83c0622cd0667a6bde8d1cca5cba0fd (commit)
via 39864d20149e29e23555ffcfd13478663d6dfb32 (commit)
via 66be42cb3859d05ab69132e15cc2bd2bbd76d279 (commit)
via b07a74497a85c3e5ed7dec1228c6441be0a8059f (commit)
via 85b3dd6cc2ca2102058a9c3db7b81d4015cfb0e3 (commit)
via 8fb678718ca38089d873a3d91ab9530e9bb7f15f (commit)
via ce9b7cc22c19da07f3cdc686797cfbc5e92961ee (commit)
via 76c50ec52e87d7d269948bce634e5b0f6e6ae70a (commit)
via 5950f674bfab2dc845b233f486ff3e1b5d6709db (commit)
via df9cd3b447d5dd1397b792a6a241e9136cc1b86f (commit)
via c7e0d2f81c6c9761337f52c0a44c024ad5a3e82a (commit)
via c64c51ebb09e305e80a13a872a23197b39453f21 (commit)
via 6bb004c435441552c29e1c29d0ba5cca328d038b (commit)
via 9083c48d37e89f45a155be7fdec2029a54259fbd (commit)
via 13f022c9f78b5a5e8e59b2afde8a8f21f7bb5e78 (commit)
via 9b90b453984a92e7e2d5f9ee0da97d33ff39fdc4 (commit)
via 1c2f9636dcd6a4fde0a8df989f09cd82704d09af (commit)
via 0e5b7e74e40408628413a1035c9b4de57de0f5da (commit)
via f6e0a4a60c1b4e93d23b133777881f69dfd36a86 (commit)
via 805b82118957a3371cf002cbe71fabc4a238f908 (commit)
via 1631817977d87fcf618a5efb510f9b351d2fcb0d (commit)
via b05ca4abb95b9b9bc4df804806f6ad95da881755 (commit)
via 35724ee1dc5b48aa80b437950444cbe40c8e350e (commit)
via 0ab2a63af1a7ff4febfe97babb3053fbf483b704 (commit)
via ddc9006b5d0e9d1fe6eb66c78cdcc51bbadf5d3c (commit)
via 5bdd388cf096eb6b361b3a67afe71cf38edd54a2 (commit)
via d273b826565d9463db4b5d6a8789d50918efdf78 (commit)
via 5bcc6d9e702a2a363e01d43a74937a09e2b73c7e (commit)
via 48489836e2ca99939db6eb85f502776a3fe7f799 (commit)
via ed5276f8279fe7a086d12de3a82116f55e59bbfe (commit)
via d9806be1448a15fd4f27dbba56286432962706cb (commit)
via 14b288ceb989fc9d5034c1145dad272cdadb6829 (commit)
via 85bc6238bfa628c84e11f9202128cad479d75524 (commit)
via 12ca82caa2e52cceeb2981399da9f661ca4e784e (commit)
via 0c5fe7d804e3735c592edd92722697751c40aedb (commit)
via 0a32abc462156f5891cd990ef1f38f8a7915ca22 (commit)
via e5a361d1f9c7ff150ae740abcf66a85467b1deca (commit)
via 03e00c5c9ddbeda56543da94601142df40e2bcbb (commit)
via d4cb18ad9cf09f54552d82463acf1269a11a8764 (commit)
via 5fa5bf7d1093c62b7831826caed74eb08fc82138 (commit)
via 97d9da9a87aa5865713994be214ff1adbc8866f3 (commit)
via 221dc803b00195c1ae05d5ea70c5ba9a156d987c (commit)
via d5da7661c8710fa8dad66ca93b021c2e5158390a (commit)
via d5ac6923c38cdf4b62e0bdbc911611ae35a07c1c (commit)
via b652e2b93fbcbc43ac8b1e7d7587904f0bf2bc62 (commit)
via 80687f2e4b50a41cb3b3ebe0cd5a05d7d71d414c (commit)
via a338fa3d87a89d5ea16e585ddabe20a254e37b02 (commit)
via 59e46065ce209c591eda15976de60e82eb7766a7 (commit)
via 8f2f65668a0aff9e5cddc6932d6026d6f4f0b462 (commit)
via 9b15703d79dcac78581287bd8ef6f7f905873c36 (commit)
via b0a9f1b4b45b644ba7617b3993ba2a7bf236f786 (commit)
via 16254e5a09faeccd4681958d4500d69a975e0319 (commit)
via 30439aa8bbc8800a09b29458e4edb18973694b82 (commit)
via 9348168ed53d1d24a4936e384c04da45d5c89b4f (commit)
via 6937c7aa8b36037a546e0825fafc933dbd5cf90b (commit)
via 5d351f0b9b77d0ba38e6da4604470472ab2ce165 (commit)
from d019ef92886bebc2d0e79db7c16abacc50b6f77d (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 663c5875f516ae9b36c6100dddd328de4c115147
Author: BT Templeton <address@hidden>
Date: Mon Mar 5 18:10:29 2012 -0500
use #nil as default for elisp rest parameters
* module/langauge/elisp/compile-tree-il.scm (compile-lambda): Bind the
rest parameter to `#nil' instead of `()' by default.
commit 5ddd9645c94f339f8795bf9b3ece8d518a8de004
Merge: d019ef9 eaeda0d
Author: BT Templeton <address@hidden>
Date: Mon Mar 5 16:52:05 2012 -0500
Merge branch 'bt/elisp'
Conflicts:
am/guilec
libguile/_scm.h
libguile/vm-i-scheme.c
module/language/elisp/compile-tree-il.scm
module/language/elisp/runtime.scm
module/language/elisp/runtime/macros.scm
module/language/tree-il/compile-glil.scm
module/language/tree-il/primitives.scm
commit eaeda0d550c513f4d134304d9adda28e1d65a23b
Author: BT Templeton <address@hidden>
Date: Tue Aug 16 23:49:56 2011 -0400
function binding fixes
* module/language/elisp/bindings.scm (bindings): Add `function-bindings'
field.
(make-bindings): Initialize the `function-bindings' field.
(get-function-binding, with-function-bindings): New functions.
(access-variable, reference-variable, set-variable!): Remove the
`module' argument and only handle references to the value cell. All
callers changed. Callers passing `function-slot' as the module changed
to use the corresponding functions for the function cell instead.
(access-function, reference-function, set-function!): New procedures.
(compile-flet, compile-labels): Use `with-function-bindings' instead
of `with-lexical-bindings'.
commit 5199c059e83c0622cd0667a6bde8d1cca5cba0fd
Author: BT Templeton <address@hidden>
Date: Tue Aug 16 23:16:46 2011 -0400
sharpsign-colon for uninterned symbols
* module/language/elisp/lexer.sm (lex): Add support for `#:' syntax for
uninterned symbols.
commit 39864d20149e29e23555ffcfd13478663d6dfb32
Author: BT Templeton <address@hidden>
Date: Sun Aug 14 17:36:38 2011 -0400
elisp I/O
* module/language/elisp/boot.el (princ, print, terpri, format*): New
functions.
commit 66be42cb3859d05ab69132e15cc2bd2bbd76d279
Author: BT Templeton <address@hidden>
Date: Sun Aug 14 16:54:14 2011 -0400
improve management of global special variables
* module/language/elisp/bindings.scm (bindings): Remove `globals'
field. (global?, mark-global!, map-globals): Remove. All callers
changed.
* module/language/elisp/compile-tree-il.scm (generate-ensure-global,
ensuring-globals): Remove. All callers changed.
(global?, ensure-globals!): New procedures.
(bind-lexically?): Use new `global?'.
(compile-lambda, compile-let, compile-let*): Use `ensure-globals!'.
commit b07a74497a85c3e5ed7dec1228c6441be0a8059f
Author: BT Templeton <address@hidden>
Date: Sun Aug 14 16:42:37 2011 -0400
more lexical declarations
* module/language/elisp/boot.el (condition-case, catch): Add `lexical'
declarations in macro expansions.
commit 85b3dd6cc2ca2102058a9c3db7b81d4015cfb0e3
Author: BT Templeton <address@hidden>
Date: Fri Aug 12 16:34:16 2011 -0400
signal an error for uncaught throws
* module/language/elisp/boot.el (%catch): New variable.
(catch): Bind `%catch' to `t' during the evaluation of `body'. Call
`throw' instead of signalling an exception directly.
(throw): Signal a `no-catch' error if there is no `catch' to throw to.
commit 8fb678718ca38089d873a3d91ab9530e9bb7f15f
Author: BT Templeton <address@hidden>
Date: Fri Aug 12 15:57:17 2011 -0400
`catch' in terms of `condition-case'
* module/language/elisp/boot.el (throw): Define an `error-conditions'
property for this symbol.
(catch): Define in terms of `condition-case' instead of using Guile
exceptions directly.
(throw): Signal a `throw' condition instead of throwing a Guile
exception directly.
commit ce9b7cc22c19da07f3cdc686797cfbc5e92961ee
Author: BT Templeton <address@hidden>
Date: Thu Aug 11 23:56:55 2011 -0400
standard error symbols
* module/language/elisp/boot.el (error, wrong-type-argument, no-catch,
invalid-function): Define `error-conditions' properties for these
standard error symbols.
commit 76c50ec52e87d7d269948bce634e5b0f6e6ae70a
Author: BT Templeton <address@hidden>
Date: Thu Aug 11 23:47:36 2011 -0400
`%plist-member' fix
* module/language/elisp/boot.el (%plist-member): Use recursion to avoid
using `catch' and `throw'.
commit 5950f674bfab2dc845b233f486ff3e1b5d6709db
Author: BT Templeton <address@hidden>
Date: Thu Aug 11 23:41:30 2011 -0400
condition-case
* module/language/elisp/boot.el (signal): Accept only two arguments, and
throw an `elisp-condition' exception instead of an `elisp-error'
exception.
(condition-case): New macro.
commit df9cd3b447d5dd1397b792a6a241e9136cc1b86f
Author: BT Templeton <address@hidden>
Date: Thu Aug 11 23:20:37 2011 -0400
elisp `member' subrs
* module/language/elisp/boot.el (%member, member, memql, memq): New
functions.
commit c7e0d2f81c6c9761337f52c0a44c024ad5a3e82a
Author: BT Templeton <address@hidden>
Date: Mon Aug 8 23:40:07 2011 -0400
use `dynlet' for dynamic binding
* module/language/elisp/compile-tree-il.scm (let-dynamic): Remove. All
callers changed to use `dynlet' instead.
commit c64c51ebb09e305e80a13a872a23197b39453f21
Author: BT Templeton <address@hidden>
Date: Mon Aug 8 20:47:03 2011 -0400
inline `generate-let' and `generate-let*'
* module/language/elisp/compile-tree-il.scm (generate-let, compile-let):
Inline the former into the latter.
(generate-let*, compile-let*): Likewise.
commit 6bb004c435441552c29e1c29d0ba5cca328d038b
Author: BT Templeton <address@hidden>
Date: Mon Aug 8 20:40:13 2011 -0400
define `flet' directly
* module/language/elisp/compile-tree-il.scm (compile-flet): Compile
`flet' directly instead of using `generate-let'.
commit 9083c48d37e89f45a155be7fdec2029a54259fbd
Author: BT Templeton <address@hidden>
Date: Mon Aug 8 20:20:16 2011 -0400
lexical binding macros
* module/language/elisp/boot.el (lexical-let, lexical-let*): New macros.
* module/language/elisp/compile-tree-il.scm (bind-lexically?): Remove
the check for a `lexical' flag, since `lexical-let' and `lexical-let*'
are no longer special operators.
(compile-lexical-let, compile-lexical-let*): Remove.
* module/language/elisp/runtime/function-slot.scm: Update module
definition.
commit 13f022c9f78b5a5e8e59b2afde8a8f21f7bb5e78
Author: BT Templeton <address@hidden>
Date: Mon Aug 8 20:15:06 2011 -0400
use `lexical' declarations in "boot.el"
* module/language/elisp/boot.el (prog1, cond, or, catch): Use `let' with
`lexical' declarations instead of `lexical-let'.
(%plist-put): Use `let' instead of `lexical-let', since "boot.el" now
uses lexical binding by default.
commit 9b90b453984a92e7e2d5f9ee0da97d33ff39fdc4
Author: BT Templeton <address@hidden>
Date: Mon Aug 8 18:53:01 2011 -0400
elisp `while' macro
* module/language/elisp/compile-tree-il.scm (compile-while): Remove.
* module/language/elisp/boot.el (while): New macro.
* module/language/elisp/runtime/function-slot.scm: Update module
definition.
commit 1c2f9636dcd6a4fde0a8df989f09cd82704d09af
Author: BT Templeton <address@hidden>
Date: Mon Aug 8 18:50:04 2011 -0400
elisp `labels'
* module/language/elisp/compile-tree-il.scm (compile-labels): New
special operator.
* module/language/elisp/runtime/function-slot.scm: Update module
definition.
commit 0e5b7e74e40408628413a1035c9b4de57de0f5da
Author: BT Templeton <address@hidden>
Date: Mon Aug 8 18:18:41 2011 -0400
fix `flet' syntax
* module/language/elisp/compile-tree-il.scm (process-let-bindings):
Remove.
(parse-let-binding, parse-flet-binding): New procedures.
(generate-let, generate-let*): Now takes an association list mapping
symbols to values for the `bindings' argument.
(compile-let, compile-let*, compile-lexical-let)
(compile-lexical-let*): Parse the bindings list with
`parse-let-binding'.
(compile-flet): Parse the bindings list with `parse-flet-binding'.
commit f6e0a4a60c1b4e93d23b133777881f69dfd36a86
Author: BT Templeton <address@hidden>
Date: Mon Aug 8 17:45:42 2011 -0400
elisp binding declarations
* module/language/elisp/compile-tree-il.scm (bind-lexically?): Accept a
new `decls' argument and check it for `lexical' declarations.
Establish the same kind of binding whether or not a lexical binding
for `sym' exists, whereas previously the presence of a lexical binding
would cause newly-established bindings to be lexical bindings as well.
(split-let-bindings): Remove. All callers changed.
(generate-let, generate-let*, compile-lambda): Pass the declarations
list to `bind-lexically?'.
* test-suite/tests/elisp-compiler.test: Explicitly disable the
lexical-binding mode. Add `lexical' declarations where necessary.
commit 805b82118957a3371cf002cbe71fabc4a238f908
Author: BT Templeton <address@hidden>
Date: Fri Aug 5 16:14:42 2011 -0400
declaration parsing
* module/language/elisp/compile-tree-il.scm (parse-body-1, parse-body)
(parse-lambda-body, parse-declaration): New procedures.
(generate-let, generate-let*): Use `parse-body'.
(compile-lambda): Use `parse-lambda-body'.
commit 1631817977d87fcf618a5efb510f9b351d2fcb0d
Author: BT Templeton <address@hidden>
Date: Sat Aug 6 19:13:10 2011 -0400
elisp lambda list parsing
* module/language/elisp/compile-tree-il.scm (split-lambda-arguments):
Remove.
(parse-lambda-list, make-simple-lambda): New procedures.
(compile-lambda): Use `parse-lambda-list' and `make-simple-lambda'.
Set empty rest arguments to the empty list instead of `#nil'.
* test-suite/tests/elisp-compiler.test ("Lambda Expressions")["rest
argument"]: Use Elisp `null' instead of a Scheme equality check.
commit b05ca4abb95b9b9bc4df804806f6ad95da881755
Author: BT Templeton <address@hidden>
Date: Mon Jul 25 13:21:55 2011 -0400
elisp function subrs
* module/language/elisp/boot.el (null, consp, listp, car, cdr)
(make-symbol, signal): Use `%funcall' instead of `funcall' or `fset'.
(symbolp, symbol-function, eval): Use `%funcall', since `funcall' now
calls these functions.
(functionp, %indirect-function): New functions.
(funcall): Define in terms of `%funcall' and `%indirect-function'.
(apply): New function. Previously defined in
"module/language/elisp/runtime/subrs.scm".
(fset): If `definition' is not a function, set the function cell of
`symbol' to an falias for `definition'.
* module/language/elisp/falias.scm: New file.
* module/language/elisp/subrs.scm: Remove file.
(apply): Remove. Now defined in "boot.el".
* module/language/elisp/runtime/function-slot.scm: Update module
definition.
* module/Makefile.am: Update.
commit 35724ee1dc5b48aa80b437950444cbe40c8e350e
Author: BT Templeton <address@hidden>
Date: Sat Jul 30 17:12:13 2011 -0400
remove dynamic function binding
* module/language/elisp/compile-tree-il.scm (find-operator): Assume that
`name' is lexically bound.
* module/language/elisp/runtime.scm (symbol-fbound?, fmakunbound!):
Assume that `symbol' is lexically bound.
(defspecial): Bind special operators lexically.
commit 0ab2a63af1a7ff4febfe97babb3053fbf483b704
Author: BT Templeton <address@hidden>
Date: Sat Jul 30 00:22:15 2011 -0400
elisp nil equality
* module/language/elisp/boot.el (eq, equal): Return `#t' if both
arguments are nil.
(eql): New function.
commit ddc9006b5d0e9d1fe6eb66c78cdcc51bbadf5d3c
Author: BT Templeton <address@hidden>
Date: Sat Jul 30 00:16:50 2011 -0400
use lexical binding in boot.el
* module/language/elisp/boot.el: Use lexical binding.
commit 5bdd388cf096eb6b361b3a67afe71cf38edd54a2
Author: BT Templeton <address@hidden>
Date: Mon Jul 25 15:04:34 2011 -0400
remove unused code
* module/language/elisp/compile-tree-il.scm (runtime-error): Remove.
* module/language/elisp/runtime.scm (macro-error, runtime-error,
elisp-bool, prim): Remove.
commit d273b826565d9463db4b5d6a8789d50918efdf78
Author: BT Templeton <address@hidden>
Date: Mon Jul 25 12:26:44 2011 -0400
new elisp special form `%funcall'
* module/language/elisp/compile-tree-il.scm (compile-%funcall): New
procedure.
* module/language/elisp/runtime/function-slot.scm: Update module
definition.
commit 5bcc6d9e702a2a363e01d43a74937a09e2b73c7e
Author: BT Templeton <address@hidden>
Date: Fri Jul 22 12:09:59 2011 -0400
rewrite `eval' and `load' in elisp
* module/language/elisp/subrs.scm (eval, load): Rewrite in Elisp and
move to...
* module/language/elisp/boot.el (eval, load): ...here.
commit 48489836e2ca99939db6eb85f502776a3fe7f799
Author: BT Templeton <address@hidden>
Date: Thu Jul 14 18:11:17 2011 -0400
evaluate the function position correctly
* module/language/elisp/compile-tree-il (compile-pair): Use `function'
to perform functional evaluation. Previously, if the operator of a
compound form was not a symbol, the operator would be evaluated as a
normal expression. This happened to work only because there is a
`lambda' macro. The compiler will now signal an error if the operator
is neither a function name nor a lambda expression.
* test-suite/tests/elisp-compiler.test ("Lambda Expressions")["optional
argument"]: Remove an erroneous use of `function' in the function
position.
commit ed5276f8279fe7a086d12de3a82116f55e59bbfe
Author: BT Templeton <address@hidden>
Date: Thu Jul 14 17:07:21 2011 -0400
purify elisp symbol cell modules
* module/language/elisp/runtime/function-slot.scm:
* module/language/elisp/runtime/value-slot.scm: Define these as pure
modules.
commit d9806be1448a15fd4f27dbba56286432962706cb
Author: BT Templeton <address@hidden>
Date: Thu Jul 14 04:09:12 2011 -0400
record elisp function names
* language/elisp/compile-tree-il.scm (compile-lambda): Add a `meta'
argument for the procedure's properties.
(compile-function, compile-defmacro, compile-defun): Update
accordingly, passing a `name' property to `compile-lambda' where
possible.
commit 14b288ceb989fc9d5034c1145dad272cdadb6829
Author: BT Templeton <address@hidden>
Date: Tue Jul 12 21:10:55 2011 -0400
elisp variable aliases
* module/language/elisp/boot.el (defvaralias): New function.
commit 85bc6238bfa628c84e11f9202128cad479d75524
Author: BT Templeton <address@hidden>
Date: Tue Jul 12 20:56:38 2011 -0400
simplify elisp symbol accessors
* module/language/elisp/boot.el (fset, symbol-value, symbol-function)
(set, makunbound, fmakunbound, boundp, fboundp): Use procedures in
`(language elisp runtime)'.
(symbolp): New function.
* module/language/elisp/compile-tree-il.scm (set-variable!): Use
`set-symbol-function!'.
* module/language/elisp/runtime.scm (reference-variable, set-variable!):
Remove.
(symbol-fluid, set-symbol-fluid!): New procedure.
(symbol-value, set-symbol-value!, symbol-function)
(set-symbol-function!, symbol-bound?, symbol-fbound?, makunbound!)
(fmakunbound!): Moved from `(language elisp subrs)' and updated to
avoid using `reference-variable' and `set-variable!'.
* module/language/elisp/runtime/subrs.scm (symbol-value)
(symbol-function, set, fset, makunbound, fmakunbound, boundp)
(fboundp): Move to `(language elisp runtime)'.
(apply): Use `symbol-function'.
commit 12ca82caa2e52cceeb2981399da9f661ca4e784e
Author: BT Templeton <address@hidden>
Date: Sun Jul 10 19:17:08 2011 -0400
elisp property lists
* module/language/elisp/boot.el (%plist-member, %plist-get, %plist-put)
(plist-get, plist-put, plist-member, lax-plist-get, lax-plist-put)
(symbol-plist, setplist, get, put): New functions.
(plist-function): New variable.
commit 0c5fe7d804e3735c592edd92722697751c40aedb
Author: BT Templeton <address@hidden>
Date: Sun Jul 10 17:33:44 2011 -0400
simplify `mark-global!'
* module/language/elisp/bindings.scm (mark-global!): Use `lset-adjoin'.
commit 0a32abc462156f5891cd990ef1f38f8a7915ca22
Author: BT Templeton <address@hidden>
Date: Sun Jul 10 17:14:32 2011 -0400
remove `flet*' elisp special form
* module/language/elisp/compile-tree-il.scm (compile-flet*): Remove.
* module/language/elisp/runtime/function-slot.scm: Update module
definition.
* test-suite/tests/elisp-compiler.test
("Lambda Expressions")["flet and flet*"]: Remove `flet*' test.
commit e5a361d1f9c7ff150ae740abcf66a85467b1deca
Author: BT Templeton <address@hidden>
Date: Sun Jul 10 17:07:42 2011 -0400
remove `with-always-lexical' elisp special form
* module/language/elisp/compile-tree-il.scm: (always-lexical): Remove.
All uses changed.
(with-added-symbols): Remove.
(compile-with-always-lexical): Remove.
(process-options!): Remove support for the `#:always-lexical' option.
* module/language/elisp/runtime/function-slot.scm: Update import and
re-export lists.
* test-suite/tests/elisp-compiler.test: Remove or update tests using
`with-always-lexical'.
commit 03e00c5c9ddbeda56543da94601142df40e2bcbb
Author: BT Templeton <address@hidden>
Date: Sat Jul 9 18:49:02 2011 -0400
emacs-compatible lexical binding
* module/language/elisp/bindings.scm (global?): New function.
* module/language/elisp/compile-tree-il.scm (lexical-binding): New
variable.
(bind-lexically?): If lexical binding is enabled, bind lexically
unless a special binding exists.
(compile-%set-lexical-binding-mode): New function.
* module/language/elisp/lexer.scm (lexical-binding-regexp): New
variable.
(lex): Return a `set-lexical-binding-mode!' token if a comment is
found while reading the first line.
* module/language/elisp/parser.scm (get-expression): Add support for
`set-lexical-binding-mode!' tokens.
* module/language/elisp/runtime/function-slot.scm: Import and re-export
the `%set-lexical-binding-mode' special form.
* test-suite/tests/elisp-compiler.test
("Let and Let*")["lambda args inside lexical-let"]: Update.
commit d4cb18ad9cf09f54552d82463acf1269a11a8764
Author: BT Templeton <address@hidden>
Date: Sat Jul 9 17:08:29 2011 -0400
remove `bind-arg-lexical?'
* module/language/elisp/compile-tree-il.scm (bind-arg-lexical?): Remove.
All callers changed to use `bind-lexically?'.
commit 5fa5bf7d1093c62b7831826caed74eb08fc82138
Author: BT Templeton <address@hidden>
Date: Thu Jul 7 23:29:31 2011 -0400
fix elisp `catch'
* module/language/elisp/boot.el (catch): Only catch exceptions of type
`elisp-exception'.
commit 97d9da9a87aa5865713994be214ff1adbc8866f3
Author: BT Templeton <address@hidden>
Date: Thu Jul 7 23:20:19 2011 -0400
implement `throw' in elisp
* module/language/elisp/runtime/subrs.scm (throw): Rewrite in Elisp and
move to...
* module/language/elisp/boot.el (throw): ...here.
commit 221dc803b00195c1ae05d5ea70c5ba9a156d987c
Author: BT Templeton <address@hidden>
Date: Thu Jul 7 23:08:22 2011 -0400
rewrite `map-globals'
* module/language/elisp/bindings.scm (map-globals): Use `append-map' and
`map' instead of explicit iteration with named `let'.
commit d5da7661c8710fa8dad66ca93b021c2e5158390a
Author: BT Templeton <address@hidden>
Date: Thu Jul 7 19:30:38 2011 -0400
use srfi-9 for elisp bindings records
* module/language/elisp/bindings.scm: Use `(srfi srfi-9)'.
(bindings-type): Remove low-level record type definition and replace
with...
(bindings): ...this, an SRFI-9 record type. All uses changed.
(mark-global-needed!): Rename to...
(mark-global!): ...this. All callers changed.
(map-globals-needed): Rename to...
(map-globals): ...this. All callers changed.
commit d5ac6923c38cdf4b62e0bdbc911611ae35a07c1c
Author: BT Templeton <address@hidden>
Date: Mon Jun 20 23:04:45 2011 -0400
fix compilation of elisp forms with empty bodies
* module/language/elisp/compile-tree-il.scm (generate-let)
(generate-let*, compile-lambda, compile-with-added-symbols)
(compile-progn, compile-if): Return nil if the form's body is empty.
* test-suite/tests/elisp-compiler.test ("Sequencing")["empty progn"]:
New test.
("Conditionals")["if with no else"]: New test.
("Let and Let*")["empty let, empty let*"]: New test.
("Lambda Expressions")["empty lambda"]: New test.
commit b652e2b93fbcbc43ac8b1e7d7587904f0bf2bc62
Author: BT Templeton <address@hidden>
Date: Mon Jun 20 17:23:13 2011 -0400
rewrite elisp macros in elisp
* module/language/elisp/runtime/macros.scm: Remove.
(macro-lambda, macro-prog1, macro-prog2, macro-cond, macro-and,
macro-or, macro-catch, macro-unwind-protect): Rewrite in Elisp and
move to...
* module/language/elisp/boot.el (lambda, prog1, prog2, cond, and, or,
catch, unwind-protect): ...here.
(eval-and-compile): New macro.
(funcall, fset, null, consp, listp, car, cdr, make-symbol-signal):
Wrap definitions in an `eval-and-compile' form so that they can be
used by the rewritten macros.
* module/language/elisp/runtime.scm: Remove `built-in-macro'.
* module/language/elisp/Makefile.am: Remove
module/language/elisp/runtime/macros.scm from `ELISP_LANG_SOURCES'.
commit 80687f2e4b50a41cb3b3ebe0cd5a05d7d71d414c
Author: BT Templeton <address@hidden>
Date: Mon Jun 20 17:08:56 2011 -0400
new elisp special form `eval-when-compile'
* module/language/elisp/compile-tree-il.scm (compile-eval-when-compile):
New function.
* module/language/elisp/runtime/function-slot.scm: Update module
definition.
commit a338fa3d87a89d5ea16e585ddabe20a254e37b02
Author: BT Templeton <address@hidden>
Date: Fri Jun 17 02:10:55 2011 -0400
remove unnecessary elisp macros
* module/language/elisp/runtime/macros.scm (when, unless, dotimes)
(dolist, pop, push): Remove. (They are not special forms in Emacs.)
* module/language/elisp/runtime/function-slot.scm: Update import and
export lists.
* test-suite/tests/elisp-compiler.test ("Conditionals")["failing when"]
["succeeding when", "failing unless", "succeeding unless"]: Remove.
("Iteration")["dotimes", "dolist"]: Remove.
("List Built-Ins")["pop", "push"]: Remove.
commit 59e46065ce209c591eda15976de60e82eb7766a7
Author: BT Templeton <address@hidden>
Date: Fri Jun 17 01:29:49 2011 -0400
elisp test fixes
* test-suite/tests/elisp-compiler.test ("Exceptions")["catch and
throw"]: Use a freshly-consed object instead of a literal object. This
test previously assumed that similar literal objects are never
identical, which no longer true.
("Equivalence Predifcates")["eq"]: Likewise.
commit 8f2f65668a0aff9e5cddc6932d6026d6f4f0b462
Author: BT Templeton <address@hidden>
Date: Fri Jun 17 00:56:34 2011 -0400
new `string' and `mapcar' elisp subrs
* module/language/elisp/boot.el (string, mapcar): New functions.
commit 9b15703d79dcac78581287bd8ef6f7f905873c36
Author: BT Templeton <address@hidden>
Date: Fri Jun 17 00:50:57 2011 -0400
rewrite elisp subrs in elisp
* module/language/elisp/runtime/subrs.scm (%, *, +, -, /=, 1+, 1-, <)
(<=, =, >, >=, abs, append, atom, car, car-safe, cdr, cdr-safe, cons)
(consp, eq, equal, fceiling, ffloor, float, floatp, fround, ftruncate)
(funcall, integerp, length, list, listp, make-list, max, min, nlistp)
(nth, nthcdr, null, numberp, reverse, setcar, setcdr, wholenump)
(zerop): Rewrite in Elisp and move to...
* module/language/elisp/boot.el: ...here. Some functions have stricter
type checking, and `elisp-bool' is not currently used (so some
predicate functions now return `#f' instead of `#nil').
(boundp, eval, fboundp, fmakunbound, fset, load, makunbound, set)
(symbol-function, symbol-value, throw): New functions; they call their
existing implementations in subrs.scm.
(@): New macro.
* module/language/elisp/runtime.scm (built-in-func): Remove. All uses
changed.
* module/language/elisp/runtime/function-slot.scm: Update module
definition.
commit b0a9f1b4b45b644ba7617b3993ba2a7bf236f786
Author: BT Templeton <address@hidden>
Date: Fri Jun 17 00:18:23 2011 -0400
remove unnecessary elisp subrs
* module/language/elisp/runtime/subrs.scm (copy-tree, number-sequence):
Remove. (They are not subrs in Emacs.)
* test-suite/tests/elisp-compiler.test ("List Built-ins")["copy-tree",
"number-sequence"]: Remove.
commit 16254e5a09faeccd4681958d4500d69a975e0319
Author: BT Templeton <address@hidden>
Date: Fri Jun 17 00:15:07 2011 -0400
`atomp' -> `atom'
* module/language/elisp/runtime/subrs.scm (atomp) Rename to...
(atom): ...this. All callers changed.
commit 30439aa8bbc8800a09b29458e4edb18973694b82
Author: BT Templeton <address@hidden>
Date: Wed Jun 15 20:23:50 2011 -0400
use `nil?' for elisp conditionals
* module/language/elisp/compile-tree-il.scm (compile-if): Use the `nil?'
primitive for conditionals.
commit 9348168ed53d1d24a4936e384c04da45d5c89b4f
Author: BT Templeton <address@hidden>
Date: Wed Jun 15 20:21:28 2011 -0400
add `nil?' primitive
* libguile/boolean.c (scm_nil_p): New function.
* libguile/vm-i-scheme.c (nilp, not_nilp):
* libguile/vm-i-system.c (br_if_nil, br_if_not_nil): New instructions.
Renumber other ops.
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Increment.
* module/language/assembly/compile-bytecode.scm (compile-bytecode): Add
support for writing `br-if-nil' and `br-if-not-nil' instructions.
* module/language/assembly/disassemble.scm (code-annotation): Add
`br-if-nil' and `br-if-not-nil' to the list of branch instructions.
* module/language/tree-il/compile-glil.scm: Add `nil?' to
`*primcall-ops*'.
(flatten): Use the new branch instructions for `nil?' conditionals.
* module/language/tree-il/primitives.scm: Add `nil?' to
`*interesting-primitive-names*', `*effect-free-primitives', and
`*effect+exception-free-primitives*'.
commit 6937c7aa8b36037a546e0825fafc933dbd5cf90b
Author: BT Templeton <address@hidden>
Date: Sun Jun 12 17:19:02 2011 -0400
load boot.el
* am/guilec: Add support for compiling Elisp files.
* module/Makefile.am: New variable ELISP_SOURCES.
* module/language/elisp/boot.el: New file.
* module/language/elisp/spec.scm: Load boot.el.
commit 5d351f0b9b77d0ba38e6da4604470472ab2ce165
Author: BT Templeton <address@hidden>
Date: Fri Jun 10 22:56:05 2011 -0400
remove void-checking cruft
* module/language/elisp/compile-tree-il.scm: Don't export
`compile-without-void-checks', which was removed. Remove unused
`disable-void-check' variable. Update comments.
-----------------------------------------------------------------------
Summary of changes:
am/guilec | 19 +-
libguile/_scm.h | 2 +-
libguile/boolean.c | 8 +
libguile/vm-i-scheme.c | 170 +++--
libguile/vm-i-system.c | 120 ++--
module/Makefile.am | 6 +-
module/language/assembly/compile-bytecode.scm | 2 +
module/language/assembly/disassemble.scm | 4 +-
module/language/elisp/bindings.scm | 80 +--
module/language/elisp/boot.el | 495 ++++++++++++
module/language/elisp/compile-tree-il.scm | 981 ++++++++++-------------
module/language/elisp/falias.scm | 27 +
module/language/elisp/lexer.scm | 33 +-
module/language/elisp/parser.scm | 2 +
module/language/elisp/runtime.scm | 143 ++--
module/language/elisp/runtime/function-slot.scm | 119 +---
module/language/elisp/runtime/macros.scm | 208 -----
module/language/elisp/runtime/subrs.scm | 383 ---------
module/language/elisp/runtime/value-slot.scm | 3 +-
module/language/elisp/spec.scm | 4 +
module/language/tree-il/compile-glil.scm | 7 +
module/language/tree-il/primitives.scm | 3 +
test-suite/tests/elisp-compiler.test | 136 +---
23 files changed, 1323 insertions(+), 1632 deletions(-)
create mode 100644 module/language/elisp/boot.el
create mode 100644 module/language/elisp/falias.scm
delete mode 100644 module/language/elisp/runtime/macros.scm
delete mode 100644 module/language/elisp/runtime/subrs.scm
diff --git a/am/guilec b/am/guilec
index 7634a97..5ef07fa 100644
--- a/am/guilec
+++ b/am/guilec
@@ -1,14 +1,14 @@
# -*- makefile -*-
-GOBJECTS = $(SOURCES:%.scm=%.go)
+GOBJECTS = $(SOURCES:%.scm=%.go) $(ELISP_SOURCES:%.el=%.go)
GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
-nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
+nobase_mod_DATA = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
ccachedir = $(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache/$(modpath)
nobase_ccache_DATA = $(GOBJECTS)
-EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
-ETAGS_ARGS = $(SOURCES) $(NOCOMP_SOURCES)
+EXTRA_DIST = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
+ETAGS_ARGS = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
CLEANFILES = $(GOBJECTS)
@@ -24,7 +24,8 @@ AM_V_GUILEC = $(AM_V_GUILEC_$(V))
AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY))
AM_V_GUILEC_0 = @echo " GUILEC" $@;
-SUFFIXES = .scm .go
+SUFFIXES = .scm .el .go
+
.scm.go:
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
@@ -32,3 +33,11 @@ SUFFIXES = .scm .go
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
-L "$(abs_top_srcdir)/guile-readline" \
-o "$@" "$<"
+
+.el.go:
+ $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
+ $(top_builddir)/meta/uninstalled-env \
+ guild compile --target="$(host)" $(GUILE_WARNINGS) \
+ -L "$(abs_srcdir)" -L "$(abs_builddir)" \
+ -L "$(abs_top_srcdir)/guile-readline" \
+ --from=elisp -o "$@" "$<"
diff --git a/libguile/_scm.h b/libguile/_scm.h
index a7a3ad2..c3384be 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -262,7 +262,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int);
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 3
-#define SCM_OBJCODE_MINOR_VERSION 0
+#define SCM_OBJCODE_MINOR_VERSION 1
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/libguile/boolean.c b/libguile/boolean.c
index 3bf672d..f8c7738 100644
--- a/libguile/boolean.c
+++ b/libguile/boolean.c
@@ -62,6 +62,14 @@ SCM_DEFINE (scm_not, "not", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_nil_p, "nil?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is nil, else return @code{#f}.")
+#define FUNC_NAME s_scm_nil_p
+{
+ return scm_from_bool (scm_is_lisp_false (x));
+}
+#undef FUNC_NAME
SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0,
(SCM obj),
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index ad16c46..89c3555 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -65,7 +65,19 @@ VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
RETURN (scm_from_bool (!scm_is_null (x)));
}
-VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
+VM_DEFINE_FUNCTION (134, nilp, "nil?", 1)
+{
+ ARGS1 (x);
+ RETURN (scm_from_bool (scm_is_lisp_false (x)));
+}
+
+VM_DEFINE_FUNCTION (135, not_nilp, "not-nil?", 1)
+{
+ ARGS1 (x);
+ RETURN (scm_from_bool (!scm_is_lisp_false (x)));
+}
+
+VM_DEFINE_FUNCTION (136, eqv, "eqv?", 2)
{
ARGS2 (x, y);
if (scm_is_eq (x, y))
@@ -76,7 +88,7 @@ VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
RETURN (scm_eqv_p (x, y));
}
-VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
+VM_DEFINE_FUNCTION (137, equal, "equal?", 2)
{
ARGS2 (x, y);
if (scm_is_eq (x, y))
@@ -87,25 +99,25 @@ VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
RETURN (scm_equal_p (x, y));
}
-VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
+VM_DEFINE_FUNCTION (138, pairp, "pair?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_is_pair (x)));
}
-VM_DEFINE_FUNCTION (137, listp, "list?", 1)
+VM_DEFINE_FUNCTION (139, listp, "list?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_ilength (x) >= 0));
}
-VM_DEFINE_FUNCTION (138, symbolp, "symbol?", 1)
+VM_DEFINE_FUNCTION (140, symbolp, "symbol?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (scm_is_symbol (x)));
}
-VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1)
+VM_DEFINE_FUNCTION (141, vectorp, "vector?", 1)
{
ARGS1 (x);
RETURN (scm_from_bool (SCM_I_IS_VECTOR (x)));
@@ -116,7 +128,7 @@ VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1)
* Basic data
*/
-VM_DEFINE_FUNCTION (140, cons, "cons", 2)
+VM_DEFINE_FUNCTION (142, cons, "cons", 2)
{
ARGS2 (x, y);
CONS (x, x, y);
@@ -130,21 +142,21 @@ VM_DEFINE_FUNCTION (140, cons, "cons", 2)
goto vm_error_not_a_pair; \
}
-VM_DEFINE_FUNCTION (141, car, "car", 1)
+VM_DEFINE_FUNCTION (143, car, "car", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x, "car");
RETURN (SCM_CAR (x));
}
-VM_DEFINE_FUNCTION (142, cdr, "cdr", 1)
+VM_DEFINE_FUNCTION (144, cdr, "cdr", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x, "cdr");
RETURN (SCM_CDR (x));
}
-VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (145, set_car, "set-car!", 0, 2, 0)
{
SCM x, y;
POP2 (y, x);
@@ -153,7 +165,7 @@ VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (146, set_cdr, "set-cdr!", 0, 2, 0)
{
SCM x, y;
POP2 (y, x);
@@ -178,27 +190,27 @@ VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
RETURN (srel (x, y)); \
}
-VM_DEFINE_FUNCTION (145, ee, "ee?", 2)
+VM_DEFINE_FUNCTION (147, ee, "ee?", 2)
{
REL (==, scm_num_eq_p);
}
-VM_DEFINE_FUNCTION (146, lt, "lt?", 2)
+VM_DEFINE_FUNCTION (148, lt, "lt?", 2)
{
REL (<, scm_less_p);
}
-VM_DEFINE_FUNCTION (147, le, "le?", 2)
+VM_DEFINE_FUNCTION (149, le, "le?", 2)
{
REL (<=, scm_leq_p);
}
-VM_DEFINE_FUNCTION (148, gt, "gt?", 2)
+VM_DEFINE_FUNCTION (150, gt, "gt?", 2)
{
REL (>, scm_gr_p);
}
-VM_DEFINE_FUNCTION (149, ge, "ge?", 2)
+VM_DEFINE_FUNCTION (151, ge, "ge?", 2)
{
REL (>=, scm_geq_p);
}
@@ -280,7 +292,7 @@ VM_DEFINE_FUNCTION (149, ge, "ge?", 2)
#endif
-VM_DEFINE_FUNCTION (150, add, "add", 2)
+VM_DEFINE_FUNCTION (152, add, "add", 2)
{
#ifndef ASM_ADD
FUNC2 (+, scm_sum);
@@ -292,7 +304,7 @@ VM_DEFINE_FUNCTION (150, add, "add", 2)
#endif
}
-VM_DEFINE_FUNCTION (151, add1, "add1", 1)
+VM_DEFINE_FUNCTION (153, add1, "add1", 1)
{
ARGS1 (x);
@@ -314,7 +326,7 @@ VM_DEFINE_FUNCTION (151, add1, "add1", 1)
RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
}
-VM_DEFINE_FUNCTION (152, sub, "sub", 2)
+VM_DEFINE_FUNCTION (154, sub, "sub", 2)
{
#ifndef ASM_SUB
FUNC2 (-, scm_difference);
@@ -326,7 +338,7 @@ VM_DEFINE_FUNCTION (152, sub, "sub", 2)
#endif
}
-VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
+VM_DEFINE_FUNCTION (155, sub1, "sub1", 1)
{
ARGS1 (x);
@@ -351,42 +363,42 @@ VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
# undef ASM_ADD
# undef ASM_SUB
-VM_DEFINE_FUNCTION (154, mul, "mul", 2)
+VM_DEFINE_FUNCTION (156, mul, "mul", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_product (x, y));
}
-VM_DEFINE_FUNCTION (155, div, "div", 2)
+VM_DEFINE_FUNCTION (157, div, "div", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_divide (x, y));
}
-VM_DEFINE_FUNCTION (156, quo, "quo", 2)
+VM_DEFINE_FUNCTION (158, quo, "quo", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_quotient (x, y));
}
-VM_DEFINE_FUNCTION (157, rem, "rem", 2)
+VM_DEFINE_FUNCTION (159, rem, "rem", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_remainder (x, y));
}
-VM_DEFINE_FUNCTION (158, mod, "mod", 2)
+VM_DEFINE_FUNCTION (160, mod, "mod", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_modulo (x, y));
}
-VM_DEFINE_FUNCTION (159, ash, "ash", 2)
+VM_DEFINE_FUNCTION (161, ash, "ash", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -415,7 +427,7 @@ VM_DEFINE_FUNCTION (159, ash, "ash", 2)
RETURN (scm_ash (x, y));
}
-VM_DEFINE_FUNCTION (160, logand, "logand", 2)
+VM_DEFINE_FUNCTION (162, logand, "logand", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -424,7 +436,7 @@ VM_DEFINE_FUNCTION (160, logand, "logand", 2)
RETURN (scm_logand (x, y));
}
-VM_DEFINE_FUNCTION (161, logior, "logior", 2)
+VM_DEFINE_FUNCTION (163, logior, "logior", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -433,7 +445,7 @@ VM_DEFINE_FUNCTION (161, logior, "logior", 2)
RETURN (scm_logior (x, y));
}
-VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
+VM_DEFINE_FUNCTION (164, logxor, "logxor", 2)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
@@ -447,7 +459,7 @@ VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
* Strings
*/
-VM_DEFINE_FUNCTION (163, string_length, "string-length", 1)
+VM_DEFINE_FUNCTION (165, string_length, "string-length", 1)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
@@ -459,7 +471,7 @@ VM_DEFINE_FUNCTION (163, string_length, "string-length", 1)
}
}
-VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2)
+VM_DEFINE_FUNCTION (166, string_ref, "string-ref", 2)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
@@ -482,7 +494,7 @@ VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2)
* Vectors and arrays
*/
-VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1)
+VM_DEFINE_FUNCTION (167, vector_length, "vector-length", 1)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
@@ -494,7 +506,7 @@ VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1)
}
}
-VM_DEFINE_FUNCTION (166, vector_ref, "vector-ref", 2)
+VM_DEFINE_FUNCTION (168, vector_ref, "vector-ref", 2)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -510,7 +522,7 @@ VM_DEFINE_FUNCTION (166, vector_ref, "vector-ref", 2)
}
}
-VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (169, vector_set, "vector-set", 0, 3, 0)
{
scm_t_signed_bits i = 0;
SCM vect, idx, val;
@@ -528,7 +540,7 @@ VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3,
0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (170, make_array, "make-array", 3, -1, 1)
{
scm_t_uint32 len;
SCM shape, ret;
@@ -557,20 +569,20 @@ VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3,
-1, 1)
goto vm_error_not_a_struct; \
}
-VM_DEFINE_FUNCTION (169, struct_p, "struct?", 1)
+VM_DEFINE_FUNCTION (171, struct_p, "struct?", 1)
{
ARGS1 (obj);
RETURN (scm_from_bool (SCM_STRUCTP (obj)));
}
-VM_DEFINE_FUNCTION (170, struct_vtable, "struct-vtable", 1)
+VM_DEFINE_FUNCTION (172, struct_vtable, "struct-vtable", 1)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
RETURN (SCM_STRUCT_VTABLE (obj));
}
-VM_DEFINE_INSTRUCTION (171, make_struct, "make-struct", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (173, make_struct, "make-struct", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -603,7 +615,7 @@ VM_DEFINE_INSTRUCTION (171, make_struct, "make-struct", 2,
-1, 1)
NEXT;
}
-VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2)
+VM_DEFINE_FUNCTION (174, struct_ref, "struct-ref", 2)
{
ARGS2 (obj, pos);
@@ -633,7 +645,7 @@ VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2)
RETURN (scm_struct_ref (obj, pos));
}
-VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3)
+VM_DEFINE_FUNCTION (175, struct_set, "struct-set", 3)
{
ARGS3 (obj, pos, val);
@@ -667,7 +679,7 @@ VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3)
/*
* GOOPS support
*/
-VM_DEFINE_FUNCTION (174, class_of, "class-of", 1)
+VM_DEFINE_FUNCTION (176, class_of, "class-of", 1)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@@ -677,7 +689,7 @@ VM_DEFINE_FUNCTION (174, class_of, "class-of", 1)
}
/* FIXME: No checking whatsoever. */
-VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2)
+VM_DEFINE_FUNCTION (177, slot_ref, "slot-ref", 2)
{
size_t slot;
ARGS2 (instance, idx);
@@ -686,7 +698,7 @@ VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2)
}
/* FIXME: No checking whatsoever. */
-VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (178, slot_set, "slot-set", 0, 3, 0)
{
SCM instance, idx, val;
size_t slot;
@@ -729,21 +741,21 @@ VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0)
#define ALIGNED_P(ptr, type) \
((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
-VM_DEFINE_FUNCTION (177, bv_u16_ref, "bv-u16-ref", 3)
+VM_DEFINE_FUNCTION (179, bv_u16_ref, "bv-u16-ref", 3)
BV_REF_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_FUNCTION (178, bv_s16_ref, "bv-s16-ref", 3)
+VM_DEFINE_FUNCTION (180, bv_s16_ref, "bv-s16-ref", 3)
BV_REF_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_FUNCTION (179, bv_u32_ref, "bv-u32-ref", 3)
+VM_DEFINE_FUNCTION (181, bv_u32_ref, "bv-u32-ref", 3)
BV_REF_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_FUNCTION (180, bv_s32_ref, "bv-s32-ref", 3)
+VM_DEFINE_FUNCTION (182, bv_s32_ref, "bv-s32-ref", 3)
BV_REF_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_FUNCTION (181, bv_u64_ref, "bv-u64-ref", 3)
+VM_DEFINE_FUNCTION (183, bv_u64_ref, "bv-u64-ref", 3)
BV_REF_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_FUNCTION (182, bv_s64_ref, "bv-s64-ref", 3)
+VM_DEFINE_FUNCTION (184, bv_s64_ref, "bv-s64-ref", 3)
BV_REF_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_FUNCTION (183, bv_f32_ref, "bv-f32-ref", 3)
+VM_DEFINE_FUNCTION (185, bv_f32_ref, "bv-f32-ref", 3)
BV_REF_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_FUNCTION (184, bv_f64_ref, "bv-f64-ref", 3)
+VM_DEFINE_FUNCTION (186, bv_f64_ref, "bv-f64-ref", 3)
BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_REF_WITH_ENDIANNESS
@@ -821,33 +833,33 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
}
-VM_DEFINE_FUNCTION (185, bv_u8_ref, "bv-u8-ref", 2)
+VM_DEFINE_FUNCTION (187, bv_u8_ref, "bv-u8-ref", 2)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
-VM_DEFINE_FUNCTION (186, bv_s8_ref, "bv-s8-ref", 2)
+VM_DEFINE_FUNCTION (188, bv_s8_ref, "bv-s8-ref", 2)
BV_FIXABLE_INT_REF (s8, s8, int8, 1)
-VM_DEFINE_FUNCTION (187, bv_u16_native_ref, "bv-u16-native-ref", 2)
+VM_DEFINE_FUNCTION (189, bv_u16_native_ref, "bv-u16-native-ref", 2)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
-VM_DEFINE_FUNCTION (188, bv_s16_native_ref, "bv-s16-native-ref", 2)
+VM_DEFINE_FUNCTION (190, bv_s16_native_ref, "bv-s16-native-ref", 2)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
-VM_DEFINE_FUNCTION (189, bv_u32_native_ref, "bv-u32-native-ref", 2)
+VM_DEFINE_FUNCTION (191, bv_u32_native_ref, "bv-u32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
#else
BV_INT_REF (u32, uint32, 4)
#endif
-VM_DEFINE_FUNCTION (190, bv_s32_native_ref, "bv-s32-native-ref", 2)
+VM_DEFINE_FUNCTION (192, bv_s32_native_ref, "bv-s32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
#else
BV_INT_REF (s32, int32, 4)
#endif
-VM_DEFINE_FUNCTION (191, bv_u64_native_ref, "bv-u64-native-ref", 2)
+VM_DEFINE_FUNCTION (193, bv_u64_native_ref, "bv-u64-native-ref", 2)
BV_INT_REF (u64, uint64, 8)
-VM_DEFINE_FUNCTION (192, bv_s64_native_ref, "bv-s64-native-ref", 2)
+VM_DEFINE_FUNCTION (194, bv_s64_native_ref, "bv-s64-native-ref", 2)
BV_INT_REF (s64, int64, 8)
-VM_DEFINE_FUNCTION (193, bv_f32_native_ref, "bv-f32-native-ref", 2)
+VM_DEFINE_FUNCTION (195, bv_f32_native_ref, "bv-f32-native-ref", 2)
BV_FLOAT_REF (f32, ieee_single, float, 4)
-VM_DEFINE_FUNCTION (194, bv_f64_native_ref, "bv-f64-native-ref", 2)
+VM_DEFINE_FUNCTION (196, bv_f64_native_ref, "bv-f64-native-ref", 2)
BV_FLOAT_REF (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_REF
@@ -870,21 +882,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8)
} \
}
-VM_DEFINE_INSTRUCTION (195, bv_u16_set, "bv-u16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (197, bv_u16_set, "bv-u16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_INSTRUCTION (196, bv_s16_set, "bv-s16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (198, bv_s16_set, "bv-s16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_INSTRUCTION (197, bv_u32_set, "bv-u32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (199, bv_u32_set, "bv-u32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_INSTRUCTION (198, bv_s32_set, "bv-s32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (200, bv_s32_set, "bv-s32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_INSTRUCTION (199, bv_u64_set, "bv-u64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (201, bv_u64_set, "bv-u64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_INSTRUCTION (200, bv_s64_set, "bv-s64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (202, bv_s64_set, "bv-s64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_INSTRUCTION (201, bv_f32_set, "bv-f32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (203, bv_f32_set, "bv-f32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_INSTRUCTION (202, bv_f64_set, "bv-f64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (204, bv_f64_set, "bv-f64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_SET_WITH_ENDIANNESS
@@ -964,33 +976,33 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (203, bv_u8_set, "bv-u8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (205, bv_u8_set, "bv-u8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (204, bv_s8_set, "bv-s8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (206, bv_s8_set, "bv-s8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (205, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (207, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (206, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (208, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX,
2)
-VM_DEFINE_INSTRUCTION (207, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (209, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
#else
BV_INT_SET (u32, uint32, 4)
#endif
-VM_DEFINE_INSTRUCTION (208, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (210, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX,
4)
#else
BV_INT_SET (s32, int32, 4)
#endif
-VM_DEFINE_INSTRUCTION (209, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (211, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
BV_INT_SET (u64, uint64, 8)
-VM_DEFINE_INSTRUCTION (210, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (212, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
BV_INT_SET (s64, int64, 8)
-VM_DEFINE_INSTRUCTION (211, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (213, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
BV_FLOAT_SET (f32, ieee_single, float, 4)
-VM_DEFINE_INSTRUCTION (212, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (214, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
BV_FLOAT_SET (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_SET
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 2fce834..114b422 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -538,12 +538,25 @@ VM_DEFINE_INSTRUCTION (40, br_if_not_null,
"br-if-not-null", 3, 0, 0)
BR (!scm_is_null (x));
}
+VM_DEFINE_INSTRUCTION (41, br_if_nil, "br-if-nil", 3, 0, 0)
+{
+ SCM x;
+ POP (x);
+ BR (scm_is_lisp_false (x));
+}
+
+VM_DEFINE_INSTRUCTION (42, br_if_not_nil, "br-if-not-nil", 3, 0, 0)
+{
+ SCM x;
+ POP (x);
+ BR (!scm_is_lisp_false (x));
+}
/*
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
+VM_DEFINE_INSTRUCTION (43, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
{
scm_t_ptrdiff n;
scm_t_int32 offset;
@@ -555,7 +568,7 @@ VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne,
"br-if-nargs-ne", 5, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
+VM_DEFINE_INSTRUCTION (44, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
{
scm_t_ptrdiff n;
scm_t_int32 offset;
@@ -567,7 +580,7 @@ VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt,
"br-if-nargs-lt", 5, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
+VM_DEFINE_INSTRUCTION (45, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
{
scm_t_ptrdiff n;
scm_t_int32 offset;
@@ -580,7 +593,7 @@ VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt,
"br-if-nargs-gt", 5, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@@ -590,7 +603,7 @@ VM_DEFINE_INSTRUCTION (44, assert_nargs_ee,
"assert-nargs-ee", 2, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@@ -600,7 +613,7 @@ VM_DEFINE_INSTRUCTION (45, assert_nargs_ge,
"assert-nargs-ge", 2, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (48, bind_optionals, "bind-optionals", 2, -1, -1)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
@@ -610,7 +623,7 @@ VM_DEFINE_INSTRUCTION (46, bind_optionals,
"bind-optionals", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle",
6, -1, -1)
+VM_DEFINE_INSTRUCTION (49, bind_optionals_shuffle, "bind-optionals/shuffle",
6, -1, -1)
{
SCM *walk;
scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
@@ -653,7 +666,7 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle,
"bind-optionals/shuffle", 6,
#define F_ALLOW_OTHER_KEYS 1
#define F_REST 2
-VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
+VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 0, 0)
{
scm_t_uint16 idx;
scm_t_ptrdiff nkw;
@@ -706,7 +719,7 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5,
0, 0)
#undef F_REST
-VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (51, push_rest, "push-rest", 2, -1, -1)
{
scm_t_ptrdiff n;
SCM rest = SCM_EOL;
@@ -719,7 +732,7 @@ VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1,
-1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1)
+VM_DEFINE_INSTRUCTION (52, bind_rest, "bind-rest", 4, -1, -1)
{
scm_t_ptrdiff n;
scm_t_uint32 i;
@@ -735,7 +748,7 @@ VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1,
-1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (53, reserve_locals, "reserve-locals", 2, -1, -1)
{
SCM *old_sp;
scm_t_int32 n;
@@ -756,7 +769,7 @@ VM_DEFINE_INSTRUCTION (51, reserve_locals,
"reserve-locals", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3)
+VM_DEFINE_INSTRUCTION (54, new_frame, "new-frame", 0, 0, 3)
{
/* NB: if you change this, see frames.c:vm-frame-num-locals */
/* and frames.h, vm-engine.c, etc of course */
@@ -771,7 +784,7 @@ VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3)
NEXT;
}
-VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
{
nargs = FETCH ();
@@ -819,7 +832,7 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1)
{
nargs = FETCH ();
@@ -870,7 +883,7 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
}
}
-VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1)
{
SCM pointer, ret;
SCM (*subr)();
@@ -939,7 +952,7 @@ VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1,
-1)
}
}
-VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (58, smob_call, "smob-call", 1, -1, -1)
{
SCM smob, ret;
SCM (*subr)();
@@ -986,7 +999,7 @@ VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1,
-1)
}
}
-VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1)
{
SCM foreign, ret;
nargs = FETCH ();
@@ -1014,7 +1027,7 @@ VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call",
1, -1, -1)
}
}
-VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
+VM_DEFINE_INSTRUCTION (60, continuation_call, "continuation-call", 0, -1, 0)
{
SCM contregs;
POP (contregs);
@@ -1030,7 +1043,7 @@ VM_DEFINE_INSTRUCTION (58, continuation_call,
"continuation-call", 0, -1, 0)
abort ();
}
-VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
+VM_DEFINE_INSTRUCTION (61, partial_cont_call, "partial-cont-call", 0, -1, 0)
{
SCM vmcont;
scm_t_ptrdiff reloc;
@@ -1081,7 +1094,7 @@ VM_DEFINE_INSTRUCTION (59, partial_cont_call,
"partial-cont-call", 0, -1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (62, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -1090,7 +1103,7 @@ VM_DEFINE_INSTRUCTION (60, tail_call_nargs,
"tail-call/nargs", 0, 0, 1)
goto vm_tail_call;
}
-VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (63, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -1099,7 +1112,7 @@ VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0,
0, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
+VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1)
{
scm_t_int32 offset;
scm_t_uint8 *mvra;
@@ -1152,7 +1165,7 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -1174,7 +1187,7 @@ VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (66, tail_apply, "tail-apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -1196,7 +1209,7 @@ VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1,
-1, 1)
goto vm_tail_call;
}
-VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (67, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, vm_cont, cont;
@@ -1234,7 +1247,7 @@ VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (68, tail_call_cc, "tail-call/cc", 0, 1, 1)
{
int first;
SCM proc, vm_cont, cont;
@@ -1277,7 +1290,7 @@ VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc",
0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1)
{
vm_return:
POP_CONTINUATION_HOOK (1);
@@ -1313,7 +1326,7 @@ VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (70, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say.
*/
@@ -1369,7 +1382,7 @@ VM_DEFINE_INSTRUCTION (68, return_values,
"return/values", 1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (71, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1392,7 +1405,7 @@ VM_DEFINE_INSTRUCTION (69, return_values_star,
"return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1)
+VM_DEFINE_INSTRUCTION (72, return_nvalues, "return/nvalues", 0, 1, -1)
{
SCM n;
POP (n);
@@ -1401,7 +1414,7 @@ VM_DEFINE_INSTRUCTION (70, return_nvalues,
"return/nvalues", 0, 1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (73, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1424,7 +1437,7 @@ VM_DEFINE_INSTRUCTION (71, truncate_values,
"truncate-values", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (74, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -1438,7 +1451,7 @@ VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (75, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -1446,7 +1459,7 @@ VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0,
0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (76, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -1454,7 +1467,7 @@ VM_DEFINE_INSTRUCTION (74, local_boxed_ref,
"local-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (77, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -1464,7 +1477,7 @@ VM_DEFINE_INSTRUCTION (75, local_boxed_set,
"local-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (78, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1475,7 +1488,7 @@ VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (79, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1486,7 +1499,7 @@ VM_DEFINE_INSTRUCTION (77, free_boxed_ref,
"free-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (80, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1498,7 +1511,7 @@ VM_DEFINE_INSTRUCTION (78, free_boxed_set,
"free-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (81, make_closure, "make-closure", 2, -1, 1)
{
size_t n, len;
SCM closure;
@@ -1517,7 +1530,7 @@ VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure",
2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (82, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1525,7 +1538,7 @@ VM_DEFINE_INSTRUCTION (80, make_variable,
"make-variable", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
+VM_DEFINE_INSTRUCTION (83, fix_closure, "fix-closure", 2, -1, 0)
{
SCM x;
unsigned int i = FETCH ();
@@ -1542,7 +1555,7 @@ VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2,
-1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
+VM_DEFINE_INSTRUCTION (84, define, "define", 0, 0, 2)
{
SCM sym, val;
POP2 (sym, val);
@@ -1553,7 +1566,7 @@ VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
NEXT;
}
-VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (85, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1561,7 +1574,7 @@ VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword",
0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (86, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1569,7 +1582,7 @@ VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0,
1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
+VM_DEFINE_INSTRUCTION (87, prompt, "prompt", 4, 2, 0)
{
scm_t_int32 offset;
scm_t_uint8 escape_only_p;
@@ -1609,7 +1622,7 @@ VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (88, wind, "wind", 0, 2, 0)
{
SCM wind, unwind;
POP2 (unwind, wind);
@@ -1623,7 +1636,7 @@ VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1)
{
unsigned n = FETCH ();
SYNC_REGISTER ();
@@ -1634,7 +1647,7 @@ VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
abort ();
}
-VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (90, unwind, "unwind", 0, 0, 0)
{
/* A normal exit from the dynamic extent of an expression. Pop the top entry
off of the dynamic stack. */
@@ -1642,7 +1655,7 @@ VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
+VM_DEFINE_INSTRUCTION (91, wind_fluids, "wind-fluids", 1, -1, 0)
{
unsigned n = FETCH ();
@@ -1655,7 +1668,7 @@ VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1,
-1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (92, unwind_fluids, "unwind-fluids", 0, 0, 0)
{
/* This function must not allocate. */
scm_dynstack_unwind_fluids (¤t_thread->dynstack,
@@ -1663,7 +1676,7 @@ VM_DEFINE_INSTRUCTION (90, unwind_fluids,
"unwind-fluids", 0, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (93, fluid_ref, "fluid-ref", 0, 1, 1)
{
size_t num;
SCM fluids;
@@ -1693,7 +1706,7 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1,
1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (94, fluid_set, "fluid-set", 0, 2, 0)
{
size_t num;
SCM val, fluid, fluids;
@@ -1713,7 +1726,7 @@ VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2,
0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals",
1, 0, 0)
+VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals",
1, 0, 0)
{
scm_t_ptrdiff n;
SCM *old_sp;
@@ -1733,7 +1746,6 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals,
"assert-nargs-ee/locals", 1,
NEXT;
}
-
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
diff --git a/module/Makefile.am b/module/Makefile.am
index 9c9d8ed..865bf89 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -135,6 +135,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 \
@@ -142,8 +143,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 = \
@@ -374,6 +373,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/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
index 85805a5..bd31930 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 ced5f26..6ad5f7d 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/elisp/bindings.scm
b/module/language/elisp/bindings.scm
index 6ff56fd..9fabddf 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 0000000..bec32b5
--- /dev/null
+++ b/module/language/elisp/boot.el
@@ -0,0 +1,495 @@
+;;; 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)))
+
+(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-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?))
+
+(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) exact?) object)
+ (funcall (@ (guile) integer?) object)))
+
+(defun numberp (object)
+ (funcall (@ (guile) real?) object))
+
+(defun wholenump (object)
+ (and (funcall (@ (guile) exact?) object)
+ (funcall (@ (guile) integer?) 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))
+
+(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))
+
+;;; Strings
+
+(defun string (&rest characters)
+ (funcall (@ (guile) list->string)
+ (mapcar (@ (guile) integer->char) characters)))
+
+;;; Sequences
+
+(fset 'length (@ (guile) length))
+
+(defun mapcar (function sequence)
+ (funcall (@ (guile) map) function sequence))
+
+;;; 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))
diff --git a/module/language/elisp/compile-tree-il.scm
b/module/language/elisp/compile-tree-il.scm
index e1d75ba..1a4d00f 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -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.
@@ -117,419 +108,253 @@
(define (report-error loc . args)
(apply error args))
-(define (runtime-error loc msg . args)
- (make-primcall 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-call loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
-
-(define (ensuring-globals loc bindings body)
- (list->seq
- 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-primcall loc 'list
- (map (lambda (sym)
- (make-module-ref loc module sym #t))
- syms))
- (make-primcall 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)))))
+ (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
+ symbol
+ (lambda (lexical)
+ (make-lexical-set loc lexical lexical value))
+ (lambda ()
+ (ensure-globals!
+ loc
+ (list symbol)
+ (call-primitive loc
+ 'fluid-set!
+ (make-module-ref loc value-slot symbol #t)
+ value)))))
-;;; 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 (access-function loc symbol handle-lexical handle-global)
+ (cond
+ ((get-function-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-global))))
-(define (set-variable! loc sym module value)
- (access-variable
+(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
- sym
- module
+ symbol
+ (lambda (gensym) (make-lexical-set loc symbol gensym value))
(lambda ()
(make-call
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))
- (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 ()
- (list->seq 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)
- (list->seq 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
- (list->seq loc (map compile-expr body))))
- (make-seq
- loc
- (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-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
@@ -547,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))))
@@ -608,52 +432,34 @@
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 ()
- (list->seq 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)
- (list->seq 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)
- (list->seq 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-seq loc
- (set-variable! loc
- sym
- value-slot
- (compile-expr value))
- (make-const loc sym))))))
+ (set-variable! loc sym (compile-expr value))
+ (make-const loc sym))))))
(defspecial defvar (loc args)
(pmatch args
@@ -678,7 +484,7 @@
(make-module-ref loc value-slot sym #t))
(make-const loc #f))
(make-void loc)
- (set-variable! loc sym value-slot (compile-expr value)))
+ (set-variable! loc sym (compile-expr value)))
(make-const loc sym))))))
(defspecial setq (loc args)
@@ -696,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
@@ -756,58 +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-call loc
- (make-lexical-ref loc
- 'iterate
- itersym)
- (list)))
- (full-body (list->seq 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
@@ -817,17 +671,19 @@
(let* ((tree-il
(make-seq
loc
- (set-variable!
+ (set-function!
loc
name
- function-slot
- (make-primcall loc 'cons
- (list (make-const loc 'macro)
- (compile-lambda loc args body))))
+ (make-call
+ loc
+ (make-module-ref loc '(guile) 'cons #t)
+ (list (make-const loc 'macro)
+ (compile-lambda loc
+ `((name . ,name))
+ args
+ body))))
(make-const loc name))))
- (compile (ensuring-globals loc bindings-data tree-il)
- #:from 'tree-il
- #:to 'value)
+ (compile tree-il #:from 'tree-il #:to 'value)
tree-il)))))
(defspecial defun (loc args)
@@ -836,10 +692,10 @@
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
(make-seq loc
- (set-variable! loc
+ (set-function! loc
name
- function-slot
(compile-lambda loc
+ `((name . ,name))
args
body))
(make-const loc name))))))
@@ -854,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)
@@ -867,13 +736,7 @@
=> (lambda (macro-function)
(compile-expr (apply macro-function arguments))))
(else
- (make-call 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.
@@ -882,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.
@@ -912,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 0000000..f043548
--- /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 af7e02a..1933ff3 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 df825eb..e83f136 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 0c84d10..6f6a220 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 896e3ce..3b10205 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 b287067..0000000
--- 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 b03a510..0000000
--- 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 c6cc3b4..c2f3666 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 3da3680..38a32c2 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/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 4b94462..79f4ff9 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -110,6 +110,7 @@
((list? . 1) . list?)
((symbol? . 1) . symbol?)
((vector? . 1) . vector?)
+ ((nil? . 1) . nil?)
(list . list)
(vector . vector)
((class-of . 1) . class-of)
@@ -527,6 +528,9 @@
((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)
@@ -538,6 +542,9 @@
((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))))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 3d98c68..3c6769d 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -46,6 +46,7 @@
ash logand logior logxor
not
pair? null? list? symbol? vector? string? struct?
+ nil?
acons cons cons*
list vector
@@ -141,6 +142,7 @@
+ * - / 1- 1+ quotient remainder modulo
not
pair? null? list? symbol? vector? struct? string?
+ nil?
string-length vector-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
@@ -168,6 +170,7 @@
ash logand logior logxor
not
pair? null? list? symbol? vector? acons cons cons*
+ nil?
list vector
car cdr
set-car! set-cdr!
diff --git a/test-suite/tests/elisp-compiler.test
b/test-suite/tests/elisp-compiler.test
index 230dc77..ddfa80a 100644
--- a/test-suite/tests/elisp-compiler.test
+++ b/test-suite/tests/elisp-compiler.test
@@ -47,6 +47,8 @@
; Test control structures.
; ========================
+(compile '(%set-lexical-binding-mode #nil) #:from 'elisp #:to 'value)
+
(with-test-prefix/compile "Sequencing"
(pass-if-equal "progn" 1
@@ -54,6 +56,9 @@
(setq a (1+ a))
a))
+ (pass-if-equal "empty progn" #nil
+ (progn))
+
(pass-if "prog1"
(progn (setq a 0)
(setq b (prog1 a (setq a (1+ a))))
@@ -77,17 +82,8 @@
3)
(equal (if nil 1) nil)))
- (pass-if-equal "failing when" nil-value
- (when nil 1 2 3))
- (pass-if-equal "succeeding when" 42
- (progn (setq a 0)
- (when t (setq a 42) a)))
-
- (pass-if-equal "failing unless" nil-value
- (unless t 1 2 3))
- (pass-if-equal "succeeding unless" 42
- (progn (setq a 0)
- (unless nil (setq a 42) a)))
+ (pass-if-equal "if with no else" #nil
+ (if nil t))
(pass-if-equal "empty cond" nil-value
(cond))
@@ -127,27 +123,7 @@
(while (<= i 5)
(setq prod (* i prod))
(setq i (1+ i)))
- prod))
-
- (pass-if "dotimes"
- (progn (setq a 0)
- (setq count 100)
- (setq b (dotimes (i count)
- (setq j (1+ i))
- (setq a (+ a j))))
- (setq c (dotimes (i 10 42) nil))
- (and (= a 5050) (equal b nil) (= c 42))))
-
- (pass-if "dolist"
- (let ((mylist '(7 2 5)))
- (setq sum 0)
- (setq a (dolist (i mylist)
- (setq sum (+ sum i))))
- (setq b (dolist (i mylist 5) 0))
- (and (= sum (+ 7 2 5))
- (equal a nil)
- (equal mylist '(7 2 5))
- (equal b 5)))))
+ prod)))
(with-test-prefix/compile "Exceptions"
@@ -169,7 +145,7 @@
(= (catch 'abc (throw 'abc 2) 1) 2)
(= (catch 'abc (catch 'def (throw 'abc (1+ 0)) 2) 3) 1)
(= (catch 'abc (catch 'def (throw 'def 1) 2) 3) 3)
- (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1)))
+ (= (catch mylist (catch (list 1 2) (throw mylist 1) 2) 3) 1)))
(pass-if "unwind-protect"
(progn (setq a 0 b 1 c 1)
@@ -246,6 +222,8 @@
(b a))
b)))
+ (pass-if-equal "empty let" #nil (let ()))
+
(pass-if "let*"
(progn (setq a 0)
(and (let* ((a 1)
@@ -257,6 +235,9 @@
(= a 0)
(not (boundp 'b)))))
+ (pass-if-equal "empty let*" #nil
+ (let* ()))
+
(pass-if "local scope"
(progn (setq a 0)
(setq b (let (a)
@@ -303,9 +284,11 @@
(lexical-let ((a 2))
(and (= a 2) (equal (dynvals) '(1 . 1))
(let ((a 3) (b a))
+ (declare (lexical a))
(and (= a 3) (= b 2)
(equal (dynvals) '(1 . 2))))
(let* ((a 4) (b a))
+ (declare (lexical a))
(and (= a 4) (= b 4)
(equal (dynvals) '(1 . 4))))
(= a 2)))
@@ -316,8 +299,11 @@
(defun dyna () a)
(lexical-let ((a 2) (b 42))
(and (= a 2) (= (dyna) 1)
- ((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3)
+ ((lambda (a)
+ (declare (lexical a))
+ (and (= a 3) (= b 42) (= (dyna) 1))) 3)
((lambda () (let ((a 3))
+ (declare (lexical a))
(and (= a 3) (= (dyna) 1)))))
(= a 2) (= (dyna) 1)))
(= a 1)))
@@ -336,34 +322,13 @@
(= (funcall c1) 4)
(= (funcall c2) 3)))
- (pass-if "always lexical option (all)"
- (progn (setq a 0)
- (defun dyna () a)
- (let ((a 1))
- (and (= a 1) (= (dyna) 0))))
- #:opts '(#:always-lexical all))
- (pass-if "always lexical option (list)"
- (progn (setq a 0 b 0)
- (defun dyna () a)
- (defun dynb () b)
- (let ((a 1)
- (b 1))
- (and (= a 1) (= (dyna) 0)
- (= b 1) (= (dynb) 1))))
- #:opts '(#:always-lexical (a)))
- (pass-if "with-always-lexical"
- (progn (setq a 0)
- (defun dyna () a)
- (with-always-lexical (a)
- (let ((a 1))
- (and (= a 1) (= (dyna) 0))))))
-
(pass-if "lexical lambda args"
(progn (setq a 1 b 1)
(defun dyna () a)
(defun dynb () b)
- (with-always-lexical (a c)
+ (lexical-let (a c)
((lambda (a b &optional c)
+ (declare (lexical a c))
(and (= a 3) (= (dyna) 1)
(= b 2) (= (dynb) 2)
(= c 1)))
@@ -373,9 +338,10 @@
; is tail-optimized by doing a deep recursion that would otherwise overflow
; the stack.
(pass-if "lexical lambda tail-recursion"
- (with-always-lexical (i)
+ (lexical-let (i)
(setq to 1000000)
(defun iteration-1 (i)
+ (declare (lexical i))
(if (< i to)
(iteration-1 (1+ i))))
(iteration-1 0)
@@ -422,14 +388,17 @@
((lambda (a b c) c) 1 2 3))
(pass-if-equal "optional argument" 3
- ((function (lambda (a &optional b c) c)) 1 2 3))
+ ((lambda (a &optional b c) c) 1 2 3))
(pass-if-equal "optional missing" nil-value
((lambda (&optional a) a)))
(pass-if-equal "rest argument" '(3 4 5)
((lambda (a b &rest c) c) 1 2 3 4 5))
- (pass-if-equal "rest missing" nil-value
- ((lambda (a b &rest c) c) 1 2)))
+ (pass-if "rest missing"
+ (null ((lambda (a b &rest c) c) 1 2)))
+
+ (pass-if-equal "empty lambda" #nil
+ ((lambda ()))))
(with-test-prefix/compile "Function Definitions"
@@ -453,18 +422,16 @@
(not (fboundp 'a))
(= a 1))))
- (pass-if "flet and flet*"
+ (pass-if "flet"
(progn (defun foobar () 42)
(defun test () (foobar))
(and (= (test) 42)
- (flet ((foobar (lambda () 0))
- (myfoo (symbol-function 'foobar)))
+ (flet ((foobar () 0)
+ (myfoo ()
+ (funcall (symbol-function 'foobar))))
(and (= (myfoo) 42)
(= (test) 42)))
- (flet* ((foobar (lambda () 0))
- (myfoo (symbol-function 'foobar)))
- (= (myfoo) 42))
- (flet (foobar)
+ (flet ((foobar () nil))
(defun foobar () 0)
(= (test) 42))
(= (test) 42)))))
@@ -563,8 +530,8 @@
(setq some-string "abc")
(and (eq 2 2) (not (eq 1 2))
(eq 'abc 'abc) (not (eq 'abc 'def))
- (eq some-string some-string) (not (eq some-string "abc"))
- (eq some-list some-list) (not (eq some-list '(1 2)))))))
+ (eq some-string some-string) (not (eq some-string (string 97
98 99)))
+ (eq some-list some-list) (not (eq some-list (list 1 2)))))))
(with-test-prefix/compile "Number Built-Ins"
@@ -607,11 +574,11 @@
(with-test-prefix/compile "List Built-Ins"
- (pass-if "consp and atomp"
+ (pass-if "consp and atom"
(and (consp '(1 2 3)) (consp '(1 2 . 3)) (consp '(a . b))
(not (consp '())) (not (consp 1)) (not (consp "abc"))
- (atomp 'a) (atomp '()) (atomp -1.5) (atomp "abc")
- (not (atomp '(1 . 2))) (not (atomp '(1)))))
+ (atom 'a) (atom '()) (atom -1.5) (atom "abc")
+ (not (atom '(1 . 2))) (not (atom '(1)))))
(pass-if "listp and nlistp"
(and (listp '(1 2 3)) (listp '(1)) (listp '()) (listp '(1 . 2))
(not (listp 'a)) (not (listp 42)) (nlistp 42)
@@ -628,15 +595,6 @@
(and (equal (car-safe '(1 2)) 1) (equal (cdr-safe '(1 2)) '(2))
(equal (car-safe 5) nil) (equal (cdr-safe 5) nil)))
- (pass-if "pop"
- (progn (setq mylist '(a b c))
- (setq value (pop mylist))
- (and (equal value 'a)
- (equal mylist '(b c)))))
- (pass-if-equal "push" '(a b c)
- (progn (setq mylist '(b c))
- (push 'a mylist)))
-
(pass-if "nth and nthcdr"
(and (equal (nth -5 '(1 2 3)) 1) (equal (nth 3 '(1 2 3)) nil)
(equal (nth 0 '(1 2 3)) 1) (equal (nth 2 '(1 2 3)) 3)
@@ -662,20 +620,6 @@
(pass-if "reverse"
(and (equal (reverse '(5 4 3 2 1)) '(1 2 3 4 5))
(equal (reverse '()) '())))
- (pass-if "copy-tree"
- (progn (setq mylist '(1 2 (3 4)))
- (and (not (eq mylist (copy-tree mylist)))
- (equal mylist (copy-tree mylist)))))
-
- (pass-if "number-sequence"
- (and (equal (number-sequence 5) '(5))
- (equal (number-sequence 5 9) '(5 6 7 8 9))
- (equal (number-sequence 5 9 3) '(5 8))
- (equal (number-sequence 5 1 -2) '(5 3 1))
- (equal (number-sequence 5 8 -1) '())
- (equal (number-sequence 5 1) '())
- (equal (number-sequence 5 5 0) '(5))))
-
(pass-if "setcar and setcdr"
(progn (setq pair '(1 . 2))
(setq copy pair)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-148-g663c587,
BT Templeton <=