mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

reformat comments

Browse source 
* module/language/elisp/bindings.scm:
* module/language/elisp/compile-tree-il.scm:
* module/language/elisp/lexer.scm:
* module/language/elisp/parser.scm:
* module/language/elisp/runtime.scm:
* module/language/elisp/runtime/function-slot.scm:
* module/language/elisp/runtime/macro-slot.scm:
* module/language/elisp/runtime/value-slot.scm: Reformat comments.
This commit is contained in:
Brian Templeton 2010-06-07 16:38:00 -04:00
parent 372b11fc73
commit 27b9476a8d
8 changed files with 478 additions and 450 deletions
Download patch file Download diff file Expand all files Collapse all files

61
module/language/elisp/bindings.scm
View file

@ -2,19 +2,20 @@
;;; Copyright (C) 2009 Free Software Foundation, Inc. ;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or modify
;;; modify it under the terms of the GNU Lesser General Public ;;; it under the terms of the GNU Lesser General Public License as
;;; License as published by the Free Software Foundation; either ;;; published by the Free Software Foundation; either version 3 of the
;;; version 3 of the License, or (at your option) any later version. ;;; License, or (at your option) any later version.
;;; ;;;
;;; This library is distributed in the hope that it will be useful, ;;; This library is distributed in the hope that it will be useful, but
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; ;;;
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software ;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA
;;; Code: ;;; Code:
@ -24,31 +25,33 @@
with-lexical-bindings with-dynamic-bindings with-lexical-bindings with-dynamic-bindings
get-lexical-binding)) get-lexical-binding))
; This module defines routines to handle analysis of symbol bindings used ;;; This module defines routines to handle analysis of symbol bindings
; during elisp compilation. This data allows to collect the symbols, for ;;; used during elisp compilation. This data allows to collect the
; which globals need to be created, or mark certain symbols as lexically bound. ;;; 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
;;; symbols to different bindings over a dynamic extent.
; Needed globals are stored in an association-list that stores a list of symbols ;;; Record type used to hold the data necessary.
; 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 symbols to different bindings
; over a dynamic extent.
; Record type used to hold the data necessary.
(define bindings-type (define bindings-type
(make-record-type 'bindings (make-record-type 'bindings
'(needed-globals lexical-bindings))) '(needed-globals lexical-bindings)))
; Construct an 'empty' instance of the bindings data structure to be used ;;; Construct an 'empty' instance of the bindings data structure to be
; at the start of a fresh compilation. ;;; used at the start of a fresh compilation.
(define (make-bindings) (define (make-bindings)
((record-constructor bindings-type) '() (make-hash-table))) ((record-constructor bindings-type) '() (make-hash-table)))
; Mark that a given symbol is needed as global in the specified slot-module. ;;; Mark that a given symbol is needed as global in the specified
;;; slot-module.
(define (mark-global-needed! bindings sym module) (define (mark-global-needed! bindings sym module)
(let* ((old-needed ((record-accessor bindings-type 'needed-globals) bindings)) (let* ((old-needed ((record-accessor bindings-type 'needed-globals) bindings))
@ -59,8 +62,8 @@
(new-needed (assoc-set! old-needed module new-in-module))) (new-needed (assoc-set! old-needed module new-in-module)))
((record-modifier bindings-type 'needed-globals) bindings new-needed))) ((record-modifier bindings-type 'needed-globals) bindings new-needed)))
; Cycle through all globals needed in order to generate the code for their ;;; Cycle through all globals needed in order to generate the code for
; creation or some other analysis. ;;; their creation or some other analysis.
(define (map-globals-needed bindings proc) (define (map-globals-needed bindings proc)
(let ((needed ((record-accessor bindings-type 'needed-globals) bindings))) (let ((needed ((record-accessor bindings-type 'needed-globals) bindings)))
@ -81,8 +84,8 @@
(cons (proc module (car sym-tail)) (cons (proc module (car sym-tail))
sym-result)))))))))) sym-result))))))))))
; Get the current lexical binding (gensym it should refer to in the current ;;; Get the current lexical binding (gensym it should refer to in the
; scope) for a symbol or #f if it is dynamically bound. ;;; current scope) for a symbol or #f if it is dynamically bound.
(define (get-lexical-binding bindings sym) (define (get-lexical-binding bindings sym)
(let* ((lex ((record-accessor bindings-type 'lexical-bindings) bindings)) (let* ((lex ((record-accessor bindings-type 'lexical-bindings) bindings))
@ -91,8 +94,8 @@
(fluid-ref slot) (fluid-ref slot)
#f))) #f)))
; Establish a binding or mark a symbol as dynamically bound for the extent of ;;; Establish a binding or mark a symbol as dynamically bound for the
; calling proc. ;;; extent of calling proc.
(define (with-symbol-bindings bindings syms targets proc) (define (with-symbol-bindings bindings syms targets proc)
(if (or (not (list? syms)) (if (or (not (list? syms))

361
module/language/elisp/compile-tree-il.scm
View file

@ -1,21 +1,21 @@
;;; Guile Emacs Lisp ;;; Guile Emacs Lisp
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;; This program is free software; you can redistribute it and/or modify ;;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by ;;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option) ;;; the Free Software Foundation; either version 3, or (at your option)
;; any later version. ;;; any later version.
;; ;;;
;; This program is distributed in the hope that it will be useful, ;;; This program is distributed in the hope that it will be useful, but
;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; GNU General Public License for more details. ;;; General Public License for more details.
;; ;;;
;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to ;;; along with this program; see the file COPYING. If not, write to the
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
;; Boston, MA 02111-1307, USA. ;;; MA 02111-1307, USA.
;;; Code: ;;; Code:
@ -27,25 +27,26 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:export (compile-tree-il)) #:export (compile-tree-il))
; Certain common parameters (like the bindings data structure or compiler ;;; Certain common parameters (like the bindings data structure or
; options) are not always passed around but accessed using fluids to simulate ;;; compiler options) are not always passed around but accessed using
; dynamic binding (hey, this is about elisp). ;;; fluids to simulate dynamic binding (hey, this is about elisp).
; The bindings data structure to keep track of symbol binding related data. ;;; The bindings data structure to keep track of symbol binding related
;;; data.
(define bindings-data (make-fluid)) (define bindings-data (make-fluid))
; Store for which symbols (or all/none) void checks are disabled. ;;; Store for which symbols (or all/none) void checks are disabled.
(define disable-void-check (make-fluid)) (define disable-void-check (make-fluid))
; Store which symbols (or all/none) should always be bound lexically, even ;;; Store which symbols (or all/none) should always be bound lexically,
; with ordinary let and as lambda arguments. ;;; even with ordinary let and as lambda arguments.
(define always-lexical (make-fluid)) (define always-lexical (make-fluid))
; Find the source properties of some parsed expression if there are any ;;; Find the source properties of some parsed expression if there are
; associated with it. ;;; any associated with it.
(define (location x) (define (location x)
(and (pair? x) (and (pair? x)
@ -53,13 +54,13 @@
(and (not (null? props)) (and (not (null? props))
props)))) props))))
; Values to use for Elisp's nil and t. ;;; Values to use for Elisp's nil and t.
(define (nil-value loc) (make-const loc (@ (language elisp runtime) nil-value))) (define (nil-value loc) (make-const loc (@ (language elisp runtime) nil-value)))
(define (t-value loc) (make-const loc (@ (language elisp runtime) t-value))) (define (t-value loc) (make-const loc (@ (language elisp runtime) t-value)))
; Modules that contain the value and function slot bindings. ;;; Modules that contain the value and function slot bindings.
(define runtime '(language elisp runtime)) (define runtime '(language elisp runtime))
@ -69,9 +70,10 @@
(define function-slot (@ (language elisp runtime) function-slot-module)) (define function-slot (@ (language elisp runtime) function-slot-module))
; The backquoting works the same as quasiquotes in Scheme, but the forms are ;;; The backquoting works the same as quasiquotes in Scheme, but the
; named differently; to make easy adaptions, we define these predicates checking ;;; forms are named differently; to make easy adaptions, we define these
; for a symbol being the car of an unquote/unquote-splicing/backquote form. ;;; predicates checking for a symbol being the car of an
;;; unquote/unquote-splicing/backquote form.
(define (backquote? sym) (define (backquote? sym)
(and (symbol? sym) (eq? sym '\`))) (and (symbol? sym) (eq? sym '\`)))
@ -82,13 +84,13 @@
(define (unquote-splicing? sym) (define (unquote-splicing? sym)
(and (symbol? sym) (eq? sym '\,@))) (and (symbol? sym) (eq? sym '\,@)))
; Build a call to a primitive procedure nicely. ;;; Build a call to a primitive procedure nicely.
(define (call-primitive loc sym . args) (define (call-primitive loc sym . args)
(make-application loc (make-primitive-ref loc sym) args)) (make-application loc (make-primitive-ref loc sym) args))
; Error reporting routine for syntax/compilation problems or build code for ;;; Error reporting routine for syntax/compilation problems or build
; a runtime-error output. ;;; code for a runtime-error output.
(define (report-error loc . args) (define (report-error loc . args)
(apply error args)) (apply error args))
@ -97,19 +99,21 @@
(make-application loc (make-primitive-ref loc 'error) (make-application loc (make-primitive-ref loc 'error)
(cons (make-const loc msg) args))) (cons (make-const loc msg) args)))
; Generate code to ensure a global symbol is there for further use of a given ;;; Generate code to ensure a global symbol is there for further use of
; symbol. In general during the compilation, those needed are only tracked with ;;; a given symbol. In general during the compilation, those needed are
; the bindings data structure. Afterwards, however, for all those needed ;;; only tracked with the bindings data structure. Afterwards, however,
; symbols the globals are really generated with this routine. ;;; for all those needed symbols the globals are really generated with
;;; this routine.
(define (generate-ensure-global loc sym module) (define (generate-ensure-global loc sym module)
(make-application loc (make-module-ref loc runtime 'ensure-fluid! #t) (make-application loc (make-module-ref loc runtime 'ensure-fluid! #t)
(list (make-const loc module) (list (make-const loc module)
(make-const loc sym)))) (make-const loc sym))))
; See if we should do a void-check for a given variable. That means, check ;;; See if we should do a void-check for a given variable. That means,
; that this check is not disabled via the compiler options for this symbol. ;;; check that this check is not disabled via the compiler options for
; Disabling of void check is only done for the value-slot module! ;;; this symbol. Disabling of void check is only done for the value-slot
;;; module!
(define (want-void-check? sym module) (define (want-void-check? sym module)
(let ((disabled (fluid-ref disable-void-check))) (let ((disabled (fluid-ref disable-void-check)))
@ -117,10 +121,10 @@
(and (not (eq? disabled 'all)) (and (not (eq? disabled 'all))
(not (memq sym disabled)))))) (not (memq sym disabled))))))
; Build a construct that establishes dynamic bindings for certain variables. ;;; Build a construct that establishes dynamic bindings for certain
; We may want to choose between binding with fluids and with-fluids* and ;;; variables. We may want to choose between binding with fluids and
; using just ordinary module symbols and setting/reverting their values with ;;; with-fluids* and using just ordinary module symbols and
; a dynamic-wind. ;;; setting/reverting their values with a dynamic-wind.
(define (let-dynamic loc syms module vals body) (define (let-dynamic loc syms module vals body)
(call-primitive loc 'with-fluids* (call-primitive loc 'with-fluids*
@ -132,9 +136,9 @@
(make-lambda loc '() (make-lambda loc '()
(make-lambda-case #f '() #f #f #f '() '() body #f)))) (make-lambda-case #f '() #f #f #f '() '() body #f))))
; Handle access to a variable (reference/setting) correctly depending on ;;; Handle access to a variable (reference/setting) correctly depending
; whether it is currently lexically or dynamically bound. ;;; on whether it is currently lexically or dynamically bound. lexical
; lexical access is done only for references to the value-slot module! ;;; access is done only for references to the value-slot module!
(define (access-variable loc sym module handle-lexical handle-dynamic) (define (access-variable loc sym module handle-lexical handle-dynamic)
(let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym))) (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
@ -142,9 +146,9 @@
(handle-lexical lexical) (handle-lexical lexical)
(handle-dynamic)))) (handle-dynamic))))
; Generate code to reference a variable. ;;; Generate code to reference a variable. For references in the
; For references in the value-slot module, we may want to generate a lexical ;;; value-slot module, we may want to generate a lexical reference
; reference instead if the variable has a lexical binding. ;;; instead if the variable has a lexical binding.
(define (reference-variable loc sym module) (define (reference-variable loc sym module)
(access-variable loc sym module (access-variable loc sym module
@ -155,7 +159,7 @@
(call-primitive loc 'fluid-ref (call-primitive loc 'fluid-ref
(make-module-ref loc module sym #t))))) (make-module-ref loc module sym #t)))))
; Reference a variable and error if the value is void. ;;; Reference a variable and error if the value is void.
(define (reference-with-check loc sym module) (define (reference-with-check loc sym module)
(if (want-void-check? sym module) (if (want-void-check? sym module)
@ -169,9 +173,9 @@
(make-lexical-ref loc 'value var)))) (make-lexical-ref loc 'value var))))
(reference-variable loc sym module))) (reference-variable loc sym module)))
; Generate code to set a variable. ;;; Generate code to set a variable. Just as with reference-variable, in
; Just as with reference-variable, in case of a reference to value-slot, ;;; case of a reference to value-slot, we want to generate a lexical set
; we want to generate a lexical set when the variable has a lexical binding. ;;; when the variable has a lexical binding.
(define (set-variable! loc sym module value) (define (set-variable! loc sym module value)
(access-variable loc sym module (access-variable loc sym module
@ -183,8 +187,9 @@
(make-module-ref loc module sym #t) (make-module-ref loc module sym #t)
value)))) value))))
; Process the bindings part of a let or let* expression; that is, check for ;;; Process the bindings part of a let or let* expression; that is,
; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...). ;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
;;; . val2) ...).
(define (process-let-bindings loc bindings) (define (process-let-bindings loc bindings)
(map (lambda (b) (map (lambda (b)
@ -198,11 +203,11 @@
(cons (car b) (cadr b)))))) (cons (car b) (cadr b))))))
bindings)) bindings))
; Split the let bindings into a list to be done lexically and one dynamically. ;;; Split the let bindings into a list to be done lexically and one
; A symbol will be bound lexically if and only if: ;;; dynamically. A symbol will be bound lexically if and only if: We're
; We're processing a lexical-let (i.e. module is 'lexical), OR ;;; processing a lexical-let (i.e. module is 'lexical), OR we're
; we're processing a value-slot binding AND ;;; processing a value-slot binding AND the symbol is already lexically
; the symbol is already lexically bound or it is always lexical. ;;; bound or it is always lexical.
(define (bind-lexically? sym module) (define (bind-lexically? sym module)
(or (eq? module 'lexical) (or (eq? module 'lexical)
@ -222,18 +227,18 @@
(iterate (cdr tail) (cons (car tail) lexical) dynamic) (iterate (cdr tail) (cons (car tail) lexical) dynamic)
(iterate (cdr tail) lexical (cons (car tail) dynamic)))))) (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
; Compile let and let* expressions. The code here is used both for let/let* ;;; Compile let and let* expressions. The code here is used both for
; and flet/flet*, just with a different bindings module. ;;; 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 ;;; A special module value 'lexical means that we're doing a lexical-let
; and the bindings should not be saved to globals at all but be done with the ;;; instead and the bindings should not be saved to globals at all but
; lexical framework instead. ;;; be done with the lexical framework instead.
; Let is done with a single call to let-dynamic binding them locally to new ;;; Let is done with a single call to let-dynamic binding them locally
; values all "at once". If there is at least one variable to bind lexically ;;; to new values all "at once". If there is at least one variable to
; among the bindings, we first do a let for all of them to evaluate all ;;; bind lexically among the bindings, we first do a let for all of them
; values before any bindings take place, and then call let-dynamic for the ;;; to evaluate all values before any bindings take place, and then call
; variables to bind dynamically. ;;; let-dynamic for the variables to bind dynamically.
(define (generate-let loc module bindings body) (define (generate-let loc module bindings body)
(let ((bind (process-let-bindings loc bindings))) (let ((bind (process-let-bindings loc bindings)))
@ -269,8 +274,8 @@
dynamic-syms) dynamic-syms)
(make-body))))))))))))) (make-body)))))))))))))
; Let* is compiled to a cascaded set of "small lets" for each binding in turn ;;; Let* is compiled to a cascaded set of "small lets" for each binding
; so that each one already sees the preceding bindings. ;;; in turn so that each one already sees the preceding bindings.
(define (generate-let* loc module bindings body) (define (generate-let* loc module bindings body)
(let ((bind (process-let-bindings loc bindings))) (let ((bind (process-let-bindings loc bindings)))
@ -295,12 +300,12 @@
`(,(caar tail)) module `(,value) `(,(caar tail)) module `(,value)
(iterate (cdr tail)))))))))) (iterate (cdr tail))))))))))
; Split the argument list of a lambda expression into required, optional and ;;; Split the argument list of a lambda expression into required,
; rest arguments and also check it is actually valid. ;;; optional and rest arguments and also check it is actually valid.
; Additionally, we create a list of all "local variables" (that is, required, ;;; Additionally, we create a list of all "local variables" (that is,
; optional and rest arguments together) and also this one split into those to ;;; required, optional and rest arguments together) and also this one
; be bound lexically and dynamically. ;;; split into those to be bound lexically and dynamically. Returned is
; Returned is as multiple values: required optional rest lexical dynamic ;;; as multiple values: required optional rest lexical dynamic
(define (bind-arg-lexical? arg) (define (bind-arg-lexical? arg)
(let ((always (fluid-ref always-lexical))) (let ((always (fluid-ref always-lexical)))
@ -362,36 +367,37 @@
(else (else
(error "invalid mode in split-lambda-arguments" mode))))))))) (error "invalid mode in split-lambda-arguments" mode)))))))))
; Compile a lambda expression. Things get a little complicated because TreeIL ;;; Compile a lambda expression. Things get a little complicated because
; does not allow optional arguments but only one rest argument, and also the ;;; TreeIL does not allow optional arguments but only one rest argument,
; rest argument should be nil instead of '() for no values given. Because of ;;; and also the rest argument should be nil instead of '() for no
; this, we have to do a little preprocessing to get everything done before the ;;; values given. Because of this, we have to do a little preprocessing
; real body is called. ;;; to get everything done before the real body is called.
; ;;;
; (lambda (a &optional b &rest c) body) should become: ;;; (lambda (a &optional b &rest c) body) should become:
; (lambda (a_ . rest_) ;;; (lambda (a_ . rest_)
; (with-fluids* (list a b c) (list a_ nil nil) ;;; (with-fluids* (list a b c) (list a_ nil nil)
; (lambda () ;;; (lambda ()
; (if (not (null? rest_)) ;;; (if (not (null? rest_))
; (begin ;;; (begin
; (fluid-set! b (car rest_)) ;;; (fluid-set! b (car rest_))
; (set! rest_ (cdr rest_)) ;;; (set! rest_ (cdr rest_))
; (if (not (null? rest_)) ;;; (if (not (null? rest_))
; (fluid-set! c rest_)))) ;;; (fluid-set! c rest_))))
; body))) ;;; body)))
; ;;;
; This is formulated very imperatively, but I think in this case that is quite ;;; This is formulated very imperatively, but I think in this case that
; clear and better than creating a lot of nested let's. ;;; is quite clear and better than creating a lot of nested let's.
; ;;;
; Another thing we have to be aware of is that lambda arguments are usually ;;; Another thing we have to be aware of is that lambda arguments are
; dynamically bound, even when a lexical binding is in tact for a symbol. ;;; usually dynamically bound, even when a lexical binding is in tact
; For symbols that are marked as 'always lexical' however, we bind them here ;;; for a symbol. For symbols that are marked as 'always lexical'
; lexically, too -- and thus we get them out of the let-dynamic call and ;;; however, we bind them here lexically, too -- and thus we get them
; register a lexical binding for them (the lexical target variable is already ;;; out of the let-dynamic call and register a lexical binding for them
; there, namely the real lambda argument from TreeIL). ;;; (the lexical target variable is already there, namely the real
; For optional arguments that are lexically bound we need to create the lexical ;;; lambda argument from TreeIL). For optional arguments that are
; bindings though with an additional let, as those arguments are not part of the ;;; lexically bound we need to create the lexical bindings though with
; ordinary argument list. ;;; an additional let, as those arguments are not part of the ordinary
;;; argument list.
(define (compile-lambda loc args body) (define (compile-lambda loc args body)
(if (not (list? args)) (if (not (list? args))
@ -469,8 +475,8 @@
full-body))) full-body)))
#f)))))))))) #f))))))))))
; Build the code to handle setting of optional arguments that are present ;;; Build the code to handle setting of optional arguments that are
; and updating the rest list. ;;; present and updating the rest list.
(define (process-optionals loc optional rest-name rest-sym) (define (process-optionals loc optional rest-name rest-sym)
(let iterate ((tail optional)) (let iterate ((tail optional))
@ -488,7 +494,7 @@
(make-lexical-ref loc rest-name rest-sym))) (make-lexical-ref loc rest-name rest-sym)))
(iterate (cdr tail)))))))) (iterate (cdr tail))))))))
; This builds the code to set the rest variable to nil if it is empty. ;;; This builds the code to set the rest variable to nil if it is empty.
(define (process-rest loc rest rest-name rest-sym) (define (process-rest loc rest rest-name rest-sym)
(let ((rest-empty (call-primitive loc 'null? (let ((rest-empty (call-primitive loc 'null?
@ -505,9 +511,9 @@
(runtime-error loc "too many arguments and no rest argument"))) (runtime-error loc "too many arguments and no rest argument")))
(else (make-void loc))))) (else (make-void loc)))))
; Handle the common part of defconst and defvar, that is, checking for a correct ;;; Handle the common part of defconst and defvar, that is, checking for
; doc string and arguments as well as maybe in the future handling the docstring ;;; a correct doc string and arguments as well as maybe in the future
; somehow. ;;; handling the docstring somehow.
(define (handle-var-def loc sym doc) (define (handle-var-def loc sym doc)
(cond (cond
@ -516,10 +522,10 @@
((and (not (null? doc)) (not (string? (car doc)))) ((and (not (null? doc)) (not (string? (car doc))))
(report-error loc "expected string as third argument of defvar, got" (report-error loc "expected string as third argument of defvar, got"
(car doc))) (car doc)))
; TODO: Handle doc string if present. ;; TODO: Handle doc string if present.
(else #t))) (else #t)))
; Handle macro bindings. ;;; Handle macro bindings.
(define (is-macro? sym) (define (is-macro? sym)
(module-defined? (resolve-interface macro-slot) sym)) (module-defined? (resolve-interface macro-slot) sym))
@ -535,7 +541,7 @@
(define (get-macro sym) (define (get-macro sym)
(module-ref (resolve-module macro-slot) sym)) (module-ref (resolve-module macro-slot) sym))
; See if a (backquoted) expression contains any unquotes. ;;; See if a (backquoted) expression contains any unquotes.
(define (contains-unquotes? expr) (define (contains-unquotes? expr)
(if (pair? expr) (if (pair? expr)
@ -545,11 +551,11 @@
(contains-unquotes? (cdr expr)))) (contains-unquotes? (cdr expr))))
#f)) #f))
; Process a backquoted expression by building up the needed cons/append calls. ;;; Process a backquoted expression by building up the needed
; For splicing, it is assumed that the expression spliced in evaluates to a ;;; cons/append calls. For splicing, it is assumed that the expression
; list. The emacs manual does not really state either it has to or what to do ;;; spliced in evaluates to a list. The emacs manual does not really
; if it does not, but Scheme explicitly forbids it and this seems reasonable ;;; state either it has to or what to do if it does not, but Scheme
; also for elisp. ;;; explicitly forbids it and this seems reasonable also for elisp.
(define (unquote-cell? expr) (define (unquote-cell? expr)
(and (list? expr) (= (length expr) 2) (unquote? (car expr)))) (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
@ -579,9 +585,9 @@
(report-error loc "non-pair expression contains unquotes" expr)) (report-error loc "non-pair expression contains unquotes" expr))
(make-const loc expr))) (make-const loc expr)))
; Temporarily update a list of symbols that are handled specially (disabled ;;; Temporarily update a list of symbols that are handled specially
; void check or always lexical) for compiling body. ;;; (disabled void check or always lexical) for compiling body. We need
; We need to handle special cases for already all / set to all and the like. ;;; to handle special cases for already all / set to all and the like.
(define (with-added-symbols loc fluid syms body) (define (with-added-symbols loc fluid syms body)
(if (null? body) (if (null? body)
@ -600,8 +606,8 @@
(with-fluids ((fluid new)) (with-fluids ((fluid new))
(make-body)))))) (make-body))))))
; Compile a symbol expression. This is a variable reference or maybe some ;;; Compile a symbol expression. This is a variable reference or maybe
; special value like nil. ;;; some special value like nil.
(define (compile-symbol loc sym) (define (compile-symbol loc sym)
(case sym (case sym
@ -609,7 +615,7 @@
((t) (t-value loc)) ((t) (t-value loc))
(else (reference-with-check loc sym value-slot)))) (else (reference-with-check loc sym value-slot))))
; Compile a pair-expression (that is, any structure-like construct). ;;; Compile a pair-expression (that is, any structure-like construct).
(define (compile-pair loc expr) (define (compile-pair loc expr)
(pmatch expr (pmatch expr
@ -631,8 +637,9 @@
(compile-expr ifclause) (compile-expr ifclause)
(make-sequence loc (map compile-expr elses)))) (make-sequence loc (map compile-expr elses))))
; defconst and defvar are kept here in the compiler (rather than doing them ;; defconst and defvar are kept here in the compiler (rather than
; as macros) for if we may want to handle the docstring somehow. ;; doing them as macros) for if we may want to handle the docstring
;; somehow.
((defconst ,sym ,value . ,doc) ((defconst ,sym ,value . ,doc)
(if (handle-var-def loc sym doc) (if (handle-var-def loc sym doc)
@ -654,9 +661,9 @@
(make-void loc)) (make-void loc))
(make-const loc sym))))) (make-const loc sym)))))
; Build a set form for possibly multiple values. The code is not formulated ;; Build a set form for possibly multiple values. The code is not
; tail recursive because it is clearer this way and large lists of symbol ;; formulated tail recursive because it is clearer this way and
; expression pairs are very unlikely. ;; large lists of symbol expression pairs are very unlikely.
((setq . ,args) (guard (not (null? args))) ((setq . ,args) (guard (not (null? args)))
(make-sequence loc (make-sequence loc
@ -679,8 +686,8 @@
(cons (set-variable! loc sym value-slot val) (cons (set-variable! loc sym value-slot val)
(iterate (cdr tailtail))))))))))) (iterate (cdr tailtail)))))))))))
; All lets (let, flet, lexical-let and let* forms) are done using the ;; All lets (let, flet, lexical-let and let* forms) are done using
; generate-let/generate-let* methods. ;; the generate-let/generate-let* methods.
((let ,bindings . ,body) (guard (and (list? bindings) ((let ,bindings . ,body) (guard (and (list? bindings)
(not (null? bindings)) (not (null? bindings))
@ -712,8 +719,8 @@
(not (null? body)))) (not (null? body))))
(generate-let* loc function-slot bindings body)) (generate-let* loc function-slot bindings body))
; Temporarily disable void checks or set symbols as always lexical only ;; Temporarily disable void checks or set symbols as always lexical
; for the lexical scope of a construct. ;; only for the lexical scope of a construct.
((without-void-checks ,syms . ,body) ((without-void-checks ,syms . ,body)
(with-added-symbols loc disable-void-check syms body)) (with-added-symbols loc disable-void-check syms body))
@ -721,30 +728,32 @@
((with-always-lexical ,syms . ,body) ((with-always-lexical ,syms . ,body)
(with-added-symbols loc always-lexical syms body)) (with-added-symbols loc always-lexical syms body))
; guile-ref allows building TreeIL's module references from within ;; guile-ref allows building TreeIL's module references from within
; elisp as a way to access data within ;; elisp as a way to access data within the Guile universe. The
; the Guile universe. The module and symbol referenced are static values, ;; module and symbol referenced are static values, just like (@
; just like (@ module symbol) does! ;; module symbol) does!
((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym))) ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym)))
(make-module-ref loc module sym #t)) (make-module-ref loc module sym #t))
; guile-primitive allows to create primitive references, which are still ;; guile-primitive allows to create primitive references, which are
; a little faster. ;; still a little faster.
((guile-primitive ,sym) (guard (symbol? sym)) ((guile-primitive ,sym) (guard (symbol? sym))
(make-primitive-ref loc sym)) (make-primitive-ref loc sym))
; A while construct is transformed into a tail-recursive loop like this: ;; A while construct is transformed into a tail-recursive loop like
; (letrec ((iterate (lambda () ;; this:
; (if condition ;;
; (begin body ;; (letrec ((iterate (lambda ()
; (iterate)) ;; (if condition
; #nil)))) ;; (begin body
; (iterate)) ;; (iterate))
; ;; #nil))))
; As letrec is not directly accessible from elisp, while is implemented here ;; (iterate))
; instead of with a macro. ;;
;; As letrec is not directly accessible from elisp, while is
;; implemented here instead of with a macro.
((while ,condition . ,body) ((while ,condition . ,body)
(let* ((itersym (gensym)) (let* ((itersym (gensym))
@ -764,8 +773,8 @@
(make-letrec loc #f '(iterate) (list itersym) (list iter-thunk) (make-letrec loc #f '(iterate) (list itersym) (list iter-thunk)
iter-call))) iter-call)))
; Either (lambda ...) or (function (lambda ...)) denotes a lambda-expression ;; Either (lambda ...) or (function (lambda ...)) denotes a
; that should be compiled. ;; lambda-expression that should be compiled.
((lambda ,args . ,body) ((lambda ,args . ,body)
(compile-lambda loc args body)) (compile-lambda loc args body))
@ -773,9 +782,9 @@
((function (lambda ,args . ,body)) ((function (lambda ,args . ,body))
(compile-lambda loc args body)) (compile-lambda loc args body))
; Build a lambda and also assign it to the function cell of some symbol. ;; Build a lambda and also assign it to the function cell of some
; This is no macro as we might want to honour the docstring at some time; ;; symbol. This is no macro as we might want to honour the docstring
; just as with defvar/defconst. ;; at some time; just as with defvar/defconst.
((defun ,name ,args . ,body) ((defun ,name ,args . ,body)
(if (not (symbol? name)) (if (not (symbol? name))
@ -785,8 +794,8 @@
(compile-lambda loc args body)) (compile-lambda loc args body))
(make-const loc name))))) (make-const loc name)))))
; Define a macro (this is done directly at compile-time!). ;; Define a macro (this is done directly at compile-time!). FIXME:
; FIXME: Recursive macros don't work! ;; Recursive macros don't work!
((defmacro ,name ,args . ,body) ((defmacro ,name ,args . ,body)
(if (not (symbol? name)) (if (not (symbol? name))
@ -797,26 +806,26 @@
(define-macro! loc name object) (define-macro! loc name object)
(make-const loc name)))) (make-const loc name))))
; XXX: Maybe we could implement backquotes in macros, too. ;; XXX: Maybe we could implement backquotes in macros, too.
((,backq ,val) (guard (backquote? backq)) ((,backq ,val) (guard (backquote? backq))
(process-backquote loc val)) (process-backquote loc val))
; XXX: Why do we need 'quote here instead of quote? ;; XXX: Why do we need 'quote here instead of quote?
(('quote ,val) (('quote ,val)
(make-const loc val)) (make-const loc val))
; Macro calls are simply expanded and recursively compiled. ;; Macro calls are simply expanded and recursively compiled.
((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro))) ((,macro . ,args) (guard (and (symbol? macro) (is-macro? macro)))
(let ((expander (get-macro macro))) (let ((expander (get-macro macro)))
(compile-expr (apply expander args)))) (compile-expr (apply expander args))))
; Function calls using (function args) standard notation; here, we have to ;; Function calls using (function args) standard notation; here, we
; take the function value of a symbol if it is one. It seems that functions ;; have to take the function value of a symbol if it is one. It
; in form of uncompiled lists are not supported in this syntax, so we don't ;; seems that functions in form of uncompiled lists are not
; have to care for them. ;; supported in this syntax, so we don't have to care for them.
((,func . ,args) ((,func . ,args)
(make-application loc (make-application loc
@ -828,7 +837,7 @@
(else (else
(report-error loc "unrecognized elisp" expr)))) (report-error loc "unrecognized elisp" expr))))
; Compile a single expression to TreeIL. ;;; Compile a single expression to TreeIL.
(define (compile-expr expr) (define (compile-expr expr)
(let ((loc (location expr))) (let ((loc (location expr)))
@ -839,8 +848,8 @@
(compile-pair loc expr)) (compile-pair loc expr))
(else (make-const loc expr))))) (else (make-const loc expr)))))
; Process the compiler options. ;;; Process the compiler options. FIXME: Why is '(()) passed as options
; FIXME: Why is '(()) passed as options by the REPL? ;;; by the REPL?
(define (valid-symbol-list-arg? value) (define (valid-symbol-list-arg? value)
(or (eq? value 'all) (or (eq? value 'all)
@ -864,10 +873,10 @@
(report-error #f "Invalid value for #:always-lexical" value))) (report-error #f "Invalid value for #:always-lexical" value)))
(else (report-error #f "Invalid compiler option" key))))))) (else (report-error #f "Invalid compiler option" key)))))))
; Entry point for compilation to TreeIL. ;;; Entry point for compilation to TreeIL. This creates the bindings
; This creates the bindings data structure, and after compiling the main ;;; data structure, and after compiling the main expression we need to
; expression we need to make sure all globals for symbols used during the ;;; make sure all globals for symbols used during the compilation are
; compilation are created using the generate-ensure-global function. ;;; created using the generate-ensure-global function.
(define (compile-tree-il expr env opts) (define (compile-tree-il expr env opts)
(values (values

206
module/language/elisp/lexer.scm
View file

@ -2,19 +2,20 @@
;;; Copyright (C) 2009 Free Software Foundation, Inc. ;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or modify
;;; modify it under the terms of the GNU Lesser General Public ;;; it under the terms of the GNU Lesser General Public License as
;;; License as published by the Free Software Foundation; either ;;; published by the Free Software Foundation; either version 3 of the
;;; version 3 of the License, or (at your option) any later version. ;;; License, or (at your option) any later version.
;;; ;;;
;;; This library is distributed in the hope that it will be useful, ;;; This library is distributed in the hope that it will be useful, but
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; ;;;
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software ;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA
;;; Code: ;;; Code:
@ -22,49 +23,51 @@
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:export (get-lexer get-lexer/1)) #:export (get-lexer get-lexer/1))
; This is the lexical analyzer for the elisp reader. It is hand-written ;;; This is the lexical analyzer for the elisp reader. It is
; instead of using some generator. I think this is the best solution ;;; hand-written instead of using some generator. I think this is the
; because of all that fancy escape sequence handling and the like. ;;; best solution because of all that fancy escape sequence handling and
;;; the like.
;;;
;;; Characters are handled internally as integers representing their
;;; code value. This is necessary because elisp allows a lot of fancy
;;; modifiers that set certain high-range bits and the resulting values
;;; would not fit into a real Scheme character range. Additionally,
;;; elisp wants characters as integers, so we just do the right thing...
;;;
;;; TODO: #@count comments
; Characters are handled internally as integers representing their ;;; Report an error from the lexer (that is, invalid input given).
; code value. This is necessary because elisp allows a lot of fancy modifiers
; that set certain high-range bits and the resulting values would not fit
; into a real Scheme character range. Additionally, elisp wants characters
; as integers, so we just do the right thing...
; TODO: #@count comments
; Report an error from the lexer (that is, invalid input given).
(define (lexer-error port msg . args) (define (lexer-error port msg . args)
(apply error msg args)) (apply error msg args))
; In a character, set a given bit. This is just some bit-wise or'ing on the ;;; In a character, set a given bit. This is just some bit-wise or'ing
; characters integer code and converting back to character. ;;; on the characters integer code and converting back to character.
(define (set-char-bit chr bit) (define (set-char-bit chr bit)
(logior chr (ash 1 bit))) (logior chr (ash 1 bit)))
; Check if a character equals some other. This is just like char=? except that ;;; Check if a character equals some other. This is just like char=?
; the tested one could be EOF in which case it simply isn't equal. ;;; except that the tested one could be EOF in which case it simply
;;; isn't equal.
(define (is-char? tested should-be) (define (is-char? tested should-be)
(and (not (eof-object? tested)) (and (not (eof-object? tested))
(char=? tested should-be))) (char=? tested should-be)))
; For a character (as integer code), find the real character it represents or ;;; For a character (as integer code), find the real character it
; #\nul if out of range. This is used to work with Scheme character functions ;;; represents or #\nul if out of range. This is used to work with
; like char-numeric?. ;;; Scheme character functions like char-numeric?.
(define (real-character chr) (define (real-character chr)
(if (< chr 256) (if (< chr 256)
(integer->char chr) (integer->char chr)
#\nul)) #\nul))
; Return the control modified version of a character. This is not just setting ;;; Return the control modified version of a character. This is not just
; a modifier bit, because ASCII conrol characters must be handled as such, and ;;; setting a modifier bit, because ASCII conrol characters must be
; in elisp C-? is the delete character for historical reasons. ;;; handled as such, and in elisp C-? is the delete character for
; Otherwise, we set bit 26. ;;; historical reasons. Otherwise, we set bit 26.
(define (add-control chr) (define (add-control chr)
(let ((real (real-character chr))) (let ((real (real-character chr)))
@ -75,12 +78,12 @@
((#\@) 0) ((#\@) 0)
(else (set-char-bit chr 26)))))) (else (set-char-bit chr 26))))))
; Parse a charcode given in some base, basically octal or hexadecimal are ;;; Parse a charcode given in some base, basically octal or hexadecimal
; needed. A requested number of digits can be given (#f means it does ;;; are needed. A requested number of digits can be given (#f means it
; not matter and arbitrary many are allowed), and additionally early ;;; does not matter and arbitrary many are allowed), and additionally
; return allowed (if fewer valid digits are found). ;;; early return allowed (if fewer valid digits are found). These
; These options are all we need to handle the \u, \U, \x and \ddd (octal digits) ;;; options are all we need to handle the \u, \U, \x and \ddd (octal
; escape sequences. ;;; digits) escape sequences.
(define (charcode-escape port base digits early-return) (define (charcode-escape port base digits early-return)
(let iterate ((result 0) (let iterate ((result 0)
@ -107,10 +110,11 @@
(lexer-error port "invalid digit in escape-code" base cur)) (lexer-error port "invalid digit in escape-code" base cur))
(iterate (+ (* result base) value) (1+ procdigs))))))) (iterate (+ (* result base) value) (1+ procdigs)))))))
; Read a character and process escape-sequences when necessary. The special ;;; Read a character and process escape-sequences when necessary. The
; in-string argument defines if this character is part of a string literal or ;;; special in-string argument defines if this character is part of a
; a single character literal, the difference being that in strings the ;;; string literal or a single character literal, the difference being
; meta modifier sets bit 7, while it is bit 27 for characters. ;;; that in strings the meta modifier sets bit 7, while it is bit 27 for
;;; characters.
(define basic-escape-codes (define basic-escape-codes
'((#\a . 7) (#\b . 8) (#\t . 9) '((#\a . 7) (#\b . 8) (#\t . 9)
@ -122,27 +126,27 @@
(#\S . 25) (#\M . ,(if in-string 7 27)))) (#\S . 25) (#\M . ,(if in-string 7 27))))
(cur (read-char port))) (cur (read-char port)))
(if (char=? cur #\\) (if (char=? cur #\\)
; Handle an escape-sequence. ;; Handle an escape-sequence.
(let* ((escaped (read-char port)) (let* ((escaped (read-char port))
(esc-code (assq-ref basic-escape-codes escaped)) (esc-code (assq-ref basic-escape-codes escaped))
(meta (assq-ref meta-bits escaped))) (meta (assq-ref meta-bits escaped)))
(cond (cond
; Meta-check must be before esc-code check because \s- must be ;; Meta-check must be before esc-code check because \s- must
; recognized as the super-meta modifier if a - follows. ;; be recognized as the super-meta modifier if a - follows. If
; If not, it will be caught as \s -> space escape code. ;; not, it will be caught as \s -> space escape code.
((and meta (is-char? (peek-char port) #\-)) ((and meta (is-char? (peek-char port) #\-))
(if (not (char=? (read-char port) #\-)) (if (not (char=? (read-char port) #\-))
(error "expected - after control sequence")) (error "expected - after control sequence"))
(set-char-bit (get-character port in-string) meta)) (set-char-bit (get-character port in-string) meta))
; One of the basic control character escape names? ;; One of the basic control character escape names?
(esc-code esc-code) (esc-code esc-code)
; Handle \ddd octal code if it is one. ;; Handle \ddd octal code if it is one.
((and (char>=? escaped #\0) (char<? escaped #\8)) ((and (char>=? escaped #\0) (char<? escaped #\8))
(begin (begin
(unread-char escaped port) (unread-char escaped port)
(charcode-escape port 8 3 #t))) (charcode-escape port 8 3 #t)))
; Check for some escape-codes directly or otherwise ;; Check for some escape-codes directly or otherwise use the
; use the escaped character literally. ;; escaped character literally.
(else (else
(case escaped (case escaped
((#\^) (add-control (get-character port in-string))) ((#\^) (add-control (get-character port in-string)))
@ -157,25 +161,26 @@
((#\u) (charcode-escape port 16 4 #f)) ((#\u) (charcode-escape port 16 4 #f))
((#\U) (charcode-escape port 16 8 #f)) ((#\U) (charcode-escape port 16 8 #f))
(else (char->integer escaped)))))) (else (char->integer escaped))))))
; No escape-sequence, just the literal character. ;; No escape-sequence, just the literal character. But remember to
; But remember to get the code instead! ;; get the code instead!
(char->integer cur)))) (char->integer cur))))
; Read a symbol or number from a port until something follows that marks the ;;; Read a symbol or number from a port until something follows that
; start of a new token (like whitespace or parentheses). The data read is ;;; marks the start of a new token (like whitespace or parentheses). The
; returned as a string for further conversion to the correct type, but we also ;;; data read is returned as a string for further conversion to the
; return what this is (integer/float/symbol). ;;; correct type, but we also return what this is
; If any escaped character is found, it must be a symbol. Otherwise we ;;; (integer/float/symbol). If any escaped character is found, it must
; at the end check the result-string against regular expressions to determine ;;; be a symbol. Otherwise we at the end check the result-string against
; if it is possibly an integer or a float. ;;; regular expressions to determine if it is possibly an integer or a
;;; float.
(define integer-regex (make-regexp "^[+-]?[0-9]+\\.?$")) (define integer-regex (make-regexp "^[+-]?[0-9]+\\.?$"))
(define float-regex (define float-regex
(make-regexp "^[+-]?([0-9]+\\.?[0-9]*|[0-9]*\\.?[0-9]+)(e[+-]?[0-9]+)?$")) (make-regexp "^[+-]?([0-9]+\\.?[0-9]*|[0-9]*\\.?[0-9]+)(e[+-]?[0-9]+)?$"))
; A dot is also allowed literally, only a single dort alone is parsed as the ;;; A dot is also allowed literally, only a single dort alone is parsed
; 'dot' terminal for dotted lists. ;;; as the 'dot' terminal for dotted lists.
(define no-escape-punctuation (string->char-set "-+=*/_~!@$%^&:<>{}?.")) (define no-escape-punctuation (string->char-set "-+=*/_~!@$%^&:<>{}?."))
@ -208,9 +213,9 @@
(unread-char c port) (unread-char c port)
(finish)))))) (finish))))))
; Parse a circular structure marker without the leading # (which was already ;;; Parse a circular structure marker without the leading # (which was
; read and recognized), that is, a number as identifier and then either ;;; already read and recognized), that is, a number as identifier and
; = or #. ;;; then either = or #.
(define (get-circular-marker port) (define (get-circular-marker port)
(call-with-values (call-with-values
@ -227,7 +232,8 @@
((#\=) `(circular-def . ,id)) ((#\=) `(circular-def . ,id))
(else (lexer-error port "invalid circular marker character" type)))))) (else (lexer-error port "invalid circular marker character" type))))))
; Main lexer routine, which is given a port and does look for the next token. ;;; Main lexer routine, which is given a port and does look for the next
;;; token.
(define (lex port) (define (lex port)
(let ((return (let ((file (if (file-port? port) (port-filename port) #f)) (let ((return (let ((file (if (file-port? port) (port-filename port) #f))
@ -239,36 +245,37 @@
(set-source-property! obj 'line line) (set-source-property! obj 'line line)
(set-source-property! obj 'column column) (set-source-property! obj 'column column)
obj)))) obj))))
; Read afterwards so the source-properties are correct above ;; Read afterwards so the source-properties are correct above
; and actually point to the very character to be read. ;; and actually point to the very character to be read.
(c (read-char port))) (c (read-char port)))
(cond (cond
; End of input must be specially marked to the parser. ;; End of input must be specially marked to the parser.
((eof-object? c) '*eoi*) ((eof-object? c) '*eoi*)
; Whitespace, just skip it. ;; Whitespace, just skip it.
((char-whitespace? c) (lex port)) ((char-whitespace? c) (lex port))
; The dot is only the one for dotted lists if followed by ;; The dot is only the one for dotted lists if followed by
; whitespace. Otherwise it is considered part of a number of symbol. ;; whitespace. Otherwise it is considered part of a number of
;; symbol.
((and (char=? c #\.) ((and (char=? c #\.)
(char-whitespace? (peek-char port))) (char-whitespace? (peek-char port)))
(return 'dot #f)) (return 'dot #f))
; Continue checking for literal character values. ;; Continue checking for literal character values.
(else (else
(case c (case c
; A line comment, skip until end-of-line is found. ;; A line comment, skip until end-of-line is found.
((#\;) ((#\;)
(let iterate () (let iterate ()
(let ((cur (read-char port))) (let ((cur (read-char port)))
(if (or (eof-object? cur) (char=? cur #\newline)) (if (or (eof-object? cur) (char=? cur #\newline))
(lex port) (lex port)
(iterate))))) (iterate)))))
; A character literal. ;; A character literal.
((#\?) ((#\?)
(return 'character (get-character port #f))) (return 'character (get-character port #f)))
; A literal string. This is mainly a sequence of characters just ;; A literal string. This is mainly a sequence of characters
; as in the character literals, the only difference is that escaped ;; just as in the character literals, the only difference is
; newline and space are to be completely ignored and that meta-escapes ;; that escaped newline and space are to be completely ignored
; set bit 7 rather than bit 27. ;; and that meta-escapes set bit 7 rather than bit 27.
((#\") ((#\")
(let iterate ((result-chars '())) (let iterate ((result-chars '()))
(let ((cur (read-char port))) (let ((cur (read-char port)))
@ -286,27 +293,27 @@
(iterate (cons (integer->char (get-character port #t)) (iterate (cons (integer->char (get-character port #t))
result-chars)))))) result-chars))))))
(else (iterate (cons cur result-chars))))))) (else (iterate (cons cur result-chars)))))))
; Circular markers (either reference or definition). ;; Circular markers (either reference or definition).
((#\#) ((#\#)
(let ((mark (get-circular-marker port))) (let ((mark (get-circular-marker port)))
(return (car mark) (cdr mark)))) (return (car mark) (cdr mark))))
; Parentheses and other special-meaning single characters. ;; Parentheses and other special-meaning single characters.
((#\() (return 'paren-open #f)) ((#\() (return 'paren-open #f))
((#\)) (return 'paren-close #f)) ((#\)) (return 'paren-close #f))
((#\[) (return 'square-open #f)) ((#\[) (return 'square-open #f))
((#\]) (return 'square-close #f)) ((#\]) (return 'square-close #f))
((#\') (return 'quote #f)) ((#\') (return 'quote #f))
((#\`) (return 'backquote #f)) ((#\`) (return 'backquote #f))
; Unquote and unquote-splicing. ;; Unquote and unquote-splicing.
((#\,) ((#\,)
(if (is-char? (peek-char port) #\@) (if (is-char? (peek-char port) #\@)
(if (not (char=? (read-char port) #\@)) (if (not (char=? (read-char port) #\@))
(error "expected @ in unquote-splicing") (error "expected @ in unquote-splicing")
(return 'unquote-splicing #f)) (return 'unquote-splicing #f))
(return 'unquote #f))) (return 'unquote #f)))
; Remaining are numbers and symbols. Process input until next ;; Remaining are numbers and symbols. Process input until next
; whitespace is found, and see if it looks like a number ;; whitespace is found, and see if it looks like a number
; (float/integer) or symbol and return accordingly. ;; (float/integer) or symbol and return accordingly.
(else (else
(unread-char c port) (unread-char c port)
(call-with-values (call-with-values
@ -315,23 +322,23 @@
(lambda (type str) (lambda (type str)
(case type (case type
((symbol) ((symbol)
; str could be empty if the first character is already ;; str could be empty if the first character is
; something not allowed in a symbol (and not escaped)! ;; already something not allowed in a symbol (and not
; Take care about that, it is an error because that character ;; escaped)! Take care about that, it is an error
; should have been handled elsewhere or is invalid in the ;; because that character should have been handled
; input. ;; elsewhere or is invalid in the input.
(if (zero? (string-length str)) (if (zero? (string-length str))
(begin (begin
; Take it out so the REPL might not get into an ;; Take it out so the REPL might not get into an
; infinite loop with further reading attempts. ;; infinite loop with further reading attempts.
(read-char port) (read-char port)
(error "invalid character in input" c)) (error "invalid character in input" c))
(return 'symbol (string->symbol str)))) (return 'symbol (string->symbol str))))
((integer) ((integer)
; In elisp, something like "1." is an integer, while ;; In elisp, something like "1." is an integer, while
; string->number returns an inexact real. Thus we ;; string->number returns an inexact real. Thus we
; need a conversion here, but it should always result in ;; need a conversion here, but it should always
; an integer! ;; result in an integer!
(return 'integer (return 'integer
(let ((num (inexact->exact (string->number str)))) (let ((num (inexact->exact (string->number str))))
(if (not (integer? num)) (if (not (integer? num))
@ -344,17 +351,16 @@
num))) num)))
(else (error "wrong number/symbol type" type))))))))))) (else (error "wrong number/symbol type" type)))))))))))
; Build a lexer thunk for a port. This is the exported routine which can be ;;; Build a lexer thunk for a port. This is the exported routine which
; used to create a lexer for the parser to use. ;;; can be used to create a lexer for the parser to use.
(define (get-lexer port) (define (get-lexer port)
(lambda () (lambda ()
(lex port))) (lex port)))
; Build a special lexer that will only read enough for one expression and then ;;; Build a special lexer that will only read enough for one expression
; always return end-of-input. ;;; and then always return end-of-input. If we find one of the quotation
; If we find one of the quotation stuff, one more expression is needed in any ;;; stuff, one more expression is needed in any case.
; case.
(define (get-lexer/1 port) (define (get-lexer/1 port)
(let ((lex (get-lexer port)) (let ((lex (get-lexer port))

108
module/language/elisp/parser.scm
View file

@ -2,19 +2,20 @@
;;; Copyright (C) 2009 Free Software Foundation, Inc. ;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or modify
;;; modify it under the terms of the GNU Lesser General Public ;;; it under the terms of the GNU Lesser General Public License as
;;; License as published by the Free Software Foundation; either ;;; published by the Free Software Foundation; either version 3 of the
;;; version 3 of the License, or (at your option) any later version. ;;; License, or (at your option) any later version.
;;; ;;;
;;; This library is distributed in the hope that it will be useful, ;;; This library is distributed in the hope that it will be useful, but
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; ;;;
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software ;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA
;;; Code: ;;; Code:
@ -22,28 +23,28 @@
#:use-module (language elisp lexer) #:use-module (language elisp lexer)
#:export (read-elisp)) #:export (read-elisp))
; The parser (reader) for elisp expressions. ;;; The parser (reader) for elisp expressions. Is is hand-written (just
; Is is hand-written (just as the lexer is) instead of using some parser ;;; as the lexer is) instead of using some parser generator because this
; generator because this allows easier transfer of source properties from the ;;; allows easier transfer of source properties from the lexer ((text
; lexer ((text parse-lalr) seems not to allow access to the original lexer ;;; parse-lalr) seems not to allow access to the original lexer
; token-pair) and is easy enough anyways. ;;; token-pair) and is easy enough anyways.
; Report a parse error. The first argument is some current lexer token ;;; Report a parse error. The first argument is some current lexer token
; where source information is available should it be useful. ;;; where source information is available should it be useful.
(define (parse-error token msg . args) (define (parse-error token msg . args)
(apply error msg args)) (apply error msg args))
; For parsing circular structures, we keep track of definitions in a ;;; For parsing circular structures, we keep track of definitions in a
; hash-map that maps the id's to their values. ;;; hash-map that maps the id's to their values. When defining a new id,
; When defining a new id, though, we immediatly fill the slot with a promise ;;; though, we immediatly fill the slot with a promise before parsing
; before parsing and setting the real value, because it must already be ;;; and setting the real value, because it must already be available at
; available at that time in case of a circular reference. The promise refers ;;; that time in case of a circular reference. The promise refers to a
; to a local variable that will be set when the real value is available through ;;; local variable that will be set when the real value is available
; a closure. After parsing the expression is completed, we work through it ;;; through a closure. After parsing the expression is completed, we
; again and force all promises we find. ;;; work through it again and force all promises we find. The
; The definitions themselves are stored in a fluid and their scope is one ;;; definitions themselves are stored in a fluid and their scope is one
; call to read-elisp (but not only the currently parsed expression!). ;;; call to read-elisp (but not only the currently parsed expression!).
(define circular-definitions (make-fluid)) (define circular-definitions (make-fluid))
@ -59,9 +60,9 @@
value value
(parse-error token "undefined circular reference" id)))) (parse-error token "undefined circular reference" id))))
; Returned is a closure that, when invoked, will set the final value. ;;; Returned is a closure that, when invoked, will set the final value.
; This means both the variable the promise will return and the hash-table ;;; This means both the variable the promise will return and the
; slot so we don't generate promises any longer. ;;; hash-table slot so we don't generate promises any longer.
(define (circular-define! token) (define (circular-define! token)
(if (not (eq? (car token) 'circular-def)) (if (not (eq? (car token) 'circular-def))
@ -74,11 +75,12 @@
(set! value real-value) (set! value real-value)
(hashq-set! table id real-value)))) (hashq-set! table id real-value))))
; Work through a parsed data structure and force the promises there. ;;; Work through a parsed data structure and force the promises there.
; After a promise is forced, the resulting value must not be recursed on; ;;; After a promise is forced, the resulting value must not be recursed
; this may lead to infinite recursion with a circular structure, and ;;; on; this may lead to infinite recursion with a circular structure,
; additionally this value was already processed when it was defined. ;;; and additionally this value was already processed when it was
; All deep data structures that can be parsed must be handled here! ;;; defined. All deep data structures that can be parsed must be handled
;;; here!
(define (force-promises! data) (define (force-promises! data)
(cond (cond
@ -99,15 +101,15 @@
(vector-set! data i (force el)) (vector-set! data i (force el))
(force-promises! el)) (force-promises! el))
(iterate (1+ i))))))) (iterate (1+ i)))))))
; Else nothing needs to be done. ;; Else nothing needs to be done.
)) ))
; We need peek-functionality for the next lexer token, this is done with some ;;; We need peek-functionality for the next lexer token, this is done
; single token look-ahead storage. This is handled by a closure which allows ;;; with some single token look-ahead storage. This is handled by a
; getting or peeking the next token. ;;; closure which allows getting or peeking the next token. When one
; When one expression is fully parsed, we don't want a look-ahead stored here ;;; expression is fully parsed, we don't want a look-ahead stored here
; because it would miss from future parsing. This is verified by the finish ;;; because it would miss from future parsing. This is verified by the
; action. ;;; finish action.
(define (make-lexer-buffer lex) (define (make-lexer-buffer lex)
(let ((look-ahead #f)) (let ((look-ahead #f))
@ -127,12 +129,12 @@
result)) result))
(else (error "invalid lexer-buffer action" action)))))))) (else (error "invalid lexer-buffer action" action))))))))
; Get the contents of a list, where the opening parentheses has already been ;;; Get the contents of a list, where the opening parentheses has
; found. The same code is used for vectors and lists, where lists allow the ;;; already been found. The same code is used for vectors and lists,
; dotted tail syntax and vectors not; additionally, the closing parenthesis ;;; where lists allow the dotted tail syntax and vectors not;
; must of course match. ;;; additionally, the closing parenthesis must of course match. The
; The implementation here is not tail-recursive, but I think it is clearer ;;; implementation here is not tail-recursive, but I think it is clearer
; and simpler this way. ;;; and simpler this way.
(define (get-list lex allow-dot close-square) (define (get-list lex allow-dot close-square)
(let* ((next (lex 'peek)) (let* ((next (lex 'peek))
@ -152,13 +154,13 @@
(parse-error next "expected exactly one element after dot")) (parse-error next "expected exactly one element after dot"))
(car tail)))) (car tail))))
(else (else
; Do both parses in exactly this sequence! ;; Do both parses in exactly this sequence!
(let* ((head (get-expression lex)) (let* ((head (get-expression lex))
(tail (get-list lex allow-dot close-square))) (tail (get-list lex allow-dot close-square)))
(cons head tail)))))) (cons head tail))))))
; Parse a single expression from a lexer-buffer. This is the main routine in ;;; Parse a single expression from a lexer-buffer. This is the main
; our recursive-descent parser. ;;; routine in our recursive-descent parser.
(define quotation-symbols '((quote . quote) (define quotation-symbols '((quote . quote)
(backquote . \`) (backquote . \`)
@ -184,7 +186,7 @@
((circular-ref) ((circular-ref)
(circular-ref token)) (circular-ref token))
((circular-def) ((circular-def)
; The order of definitions is important! ;; The order of definitions is important!
(let* ((setter (circular-define! token)) (let* ((setter (circular-define! token))
(expr (get-expression lex))) (expr (get-expression lex)))
(setter expr) (setter expr)
@ -193,9 +195,9 @@
(else (else
(parse-error token "expected expression, got" token))))) (parse-error token "expected expression, got" token)))))
; Define the reader function based on this; build a lexer, a lexer-buffer, ;;; Define the reader function based on this; build a lexer, a
; and then parse a single expression to return. ;;; lexer-buffer, and then parse a single expression to return. We also
; We also define a circular-definitions data structure to use. ;;; define a circular-definitions data structure to use.
(define (read-elisp port) (define (read-elisp port)
(with-fluids ((circular-definitions (make-circular-definitions))) (with-fluids ((circular-definitions (make-circular-definitions)))

51
module/language/elisp/runtime.scm
View file

@ -2,19 +2,20 @@
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or modify
;;; modify it under the terms of the GNU Lesser General Public ;;; it under the terms of the GNU Lesser General Public License as
;;; License as published by the Free Software Foundation; either ;;; published by the Free Software Foundation; either version 3 of the
;;; version 3 of the License, or (at your option) any later version. ;;; License, or (at your option) any later version.
;;; ;;;
;;; This library is distributed in the hope that it will be useful, ;;; This library is distributed in the hope that it will be useful, but
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; ;;;
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software ;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA
;;; Code: ;;; Code:
@ -28,45 +29,45 @@
runtime-error macro-error) runtime-error macro-error)
#:export-syntax (built-in-func built-in-macro prim)) #:export-syntax (built-in-func built-in-macro prim))
; This module provides runtime support for the Elisp front-end. ;;; This module provides runtime support for the Elisp front-end.
; The reserved value to mean (when eq?) void. ;;; The reserved value to mean (when eq?) void.
(define void (list 42)) (define void (list 42))
; Values for t and nil. (FIXME remove this abstraction) ;;; Values for t and nil. (FIXME remove this abstraction)
(define nil-value #nil) (define nil-value #nil)
(define t-value #t) (define t-value #t)
; Modules for the binding slots. ;;; Modules for the binding slots. Note: Naming those value-slot and/or
; Note: Naming those value-slot and/or function-slot clashes with the ;;; function-slot clashes with the submodules of these names!
; submodules of these names!
(define value-slot-module '(language elisp runtime value-slot)) (define value-slot-module '(language elisp runtime value-slot))
(define function-slot-module '(language elisp runtime function-slot)) (define function-slot-module '(language elisp runtime function-slot))
; Report an error during macro compilation, that means some special compilation ;;; Report an error during macro compilation, that means some special
; (syntax) error; or report a simple runtime-error from a built-in function. ;;; compilation (syntax) error; or report a simple runtime-error from a
;;; built-in function.
(define (macro-error msg . args) (define (macro-error msg . args)
(apply error msg args)) (apply error msg args))
(define runtime-error macro-error) (define runtime-error macro-error)
; Convert a scheme boolean to Elisp. ;;; Convert a scheme boolean to Elisp.
(define (elisp-bool b) (define (elisp-bool b)
(if b (if b
t-value t-value
nil-value)) nil-value))
; Routines for access to elisp dynamically bound symbols. ;;; Routines for access to elisp dynamically bound symbols. This is used
; This is used for runtime access using functions like symbol-value or set, ;;; for runtime access using functions like symbol-value or set, where
; where the symbol accessed might not be known at compile-time. ;;; the symbol accessed might not be known at compile-time. These always
; These always access the dynamic binding and can not be used for the lexical! ;;; access the dynamic binding and can not be used for the lexical!
(define (ensure-fluid! module sym) (define (ensure-fluid! module sym)
(let ((intf (resolve-interface module)) (let ((intf (resolve-interface module))
@ -94,8 +95,8 @@
(fluid-set! (module-ref resolved sym) value) (fluid-set! (module-ref resolved sym) value)
value)) value))
; Define a predefined function or predefined macro for use in the function-slot ;;; Define a predefined function or predefined macro for use in the
; and macro-slot modules, respectively. ;;; function-slot and macro-slot modules, respectively.
(define-syntax built-in-func (define-syntax built-in-func
(syntax-rules () (syntax-rules ()
@ -109,8 +110,8 @@
((_ name value) ((_ name value)
(define-public name value)))) (define-public name value))))
; Call a guile-primitive that may be rebound for elisp and thus needs absolute ;;; Call a guile-primitive that may be rebound for elisp and thus needs
; addressing. ;;; absolute addressing.
(define-syntax prim (define-syntax prim
(syntax-rules () (syntax-rules ()

57
module/language/elisp/runtime/function-slot.scm
View file

@ -2,19 +2,20 @@
;;; Copyright (C) 2009 Free Software Foundation, Inc. ;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or modify
;;; modify it under the terms of the GNU Lesser General Public ;;; it under the terms of the GNU Lesser General Public License as
;;; License as published by the Free Software Foundation; either ;;; published by the Free Software Foundation; either version 3 of the
;;; version 3 of the License, or (at your option) any later version. ;;; License, or (at your option) any later version.
;;; ;;;
;;; This library is distributed in the hope that it will be useful, ;;; This library is distributed in the hope that it will be useful, but
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; ;;;
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software ;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA
;;; Code: ;;; Code:
@ -22,10 +23,11 @@
#:use-module (language elisp runtime) #:use-module (language elisp runtime)
#:use-module (system base compile)) #:use-module (system base compile))
; This module contains the function-slots of elisp symbols. Elisp built-in ;;; This module contains the function-slots of elisp symbols. Elisp
; functions are implemented as predefined function bindings here. ;;; built-in functions are implemented as predefined function bindings
;;; here.
; Equivalence and equalness predicates. ;;; Equivalence and equalness predicates.
(built-in-func eq (lambda (a b) (built-in-func eq (lambda (a b)
(elisp-bool (eq? a b)))) (elisp-bool (eq? a b))))
@ -33,7 +35,7 @@
(built-in-func equal (lambda (a b) (built-in-func equal (lambda (a b)
(elisp-bool (equal? a b)))) (elisp-bool (equal? a b))))
; Number predicates. ;;; Number predicates.
(built-in-func floatp (lambda (num) (built-in-func floatp (lambda (num)
(elisp-bool (and (real? num) (elisp-bool (and (real? num)
@ -55,7 +57,7 @@
(built-in-func zerop (lambda (num) (built-in-func zerop (lambda (num)
(elisp-bool (prim = num 0)))) (elisp-bool (prim = num 0))))
; Number comparisons. ;;; Number comparisons.
(built-in-func = (lambda (num1 num2) (built-in-func = (lambda (num1 num2)
(elisp-bool (prim = num1 num2)))) (elisp-bool (prim = num1 num2))))
@ -83,16 +85,16 @@
(built-in-func abs (@ (guile) abs)) (built-in-func abs (@ (guile) abs))
; Number conversion. ;;; Number conversion.
(built-in-func float (lambda (num) (built-in-func float (lambda (num)
(if (exact? num) (if (exact? num)
(exact->inexact num) (exact->inexact num)
num))) num)))
; TODO: truncate, floor, ceiling, round. ;;; TODO: truncate, floor, ceiling, round.
; Arithmetic functions. ;;; Arithmetic functions.
(built-in-func 1+ (@ (guile) 1+)) (built-in-func 1+ (@ (guile) 1+))
@ -106,9 +108,10 @@
(built-in-func % (@ (guile) modulo)) (built-in-func % (@ (guile) modulo))
; TODO: / with correct integer/real behaviour, mod (for floating-piont values). ;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
;;; values).
; Floating-point rounding operations. ;;; Floating-point rounding operations.
(built-in-func ffloor (@ (guile) floor)) (built-in-func ffloor (@ (guile) floor))
@ -118,7 +121,7 @@
(built-in-func fround (@ (guile) round)) (built-in-func fround (@ (guile) round))
; List predicates. ;;; List predicates.
(built-in-func consp (built-in-func consp
(lambda (el) (lambda (el)
@ -141,7 +144,7 @@
(lambda (el) (lambda (el)
(elisp-bool (null? el)))) (elisp-bool (null? el))))
; Accessing list elements. ;;; Accessing list elements.
(built-in-func car (built-in-func car
(lambda (el) (lambda (el)
@ -191,7 +194,7 @@
(built-in-func length (@ (guile) length)) (built-in-func length (@ (guile) length))
; Building lists. ;;; Building lists.
(built-in-func cons (@ (guile) cons)) (built-in-func cons (@ (guile) cons))
@ -236,7 +239,7 @@
(prim cons i result) (prim cons i result)
(iterate (prim - i sep) (prim cons i result))))))))))) (iterate (prim - i sep) (prim cons i result)))))))))))
; Changing lists. ;;; Changing lists.
(built-in-func setcar (built-in-func setcar
(lambda (cell val) (lambda (cell val)
@ -248,7 +251,7 @@
(prim set-cdr! cell val) (prim set-cdr! cell val)
val)) val))
; Accessing symbol bindings for symbols known only at runtime. ;;; Accessing symbol bindings for symbols known only at runtime.
(built-in-func symbol-value (built-in-func symbol-value
(lambda (sym) (lambda (sym)
@ -286,8 +289,8 @@
(elisp-bool (prim not (elisp-bool (prim not
(eq? void (reference-variable function-slot-module sym)))))) (eq? void (reference-variable function-slot-module sym))))))
; Function calls. These must take care of special cases, like using symbols ;;; Function calls. These must take care of special cases, like using
; or raw lambda-lists as functions! ;;; symbols or raw lambda-lists as functions!
(built-in-func apply (built-in-func apply
(lambda (func . args) (lambda (func . args)
@ -308,13 +311,13 @@
(lambda (func . args) (lambda (func . args)
(myapply func args)))) (myapply func args))))
; Throw can be implemented as built-in function. ;;; Throw can be implemented as built-in function.
(built-in-func throw (built-in-func throw
(lambda (tag value) (lambda (tag value)
(prim throw 'elisp-exception tag value))) (prim throw 'elisp-exception tag value)))
; Miscellaneous. ;;; Miscellaneous.
(built-in-func not (built-in-func not
(lambda (x) (lambda (x)

65
module/language/elisp/runtime/macro-slot.scm
View file

@ -2,32 +2,34 @@
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or modify
;;; modify it under the terms of the GNU Lesser General Public ;;; it under the terms of the GNU Lesser General Public License as
;;; License as published by the Free Software Foundation; either ;;; published by the Free Software Foundation; either version 3 of the
;;; version 3 of the License, or (at your option) any later version. ;;; License, or (at your option) any later version.
;;; ;;;
;;; This library is distributed in the hope that it will be useful, ;;; This library is distributed in the hope that it will be useful, but
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; ;;;
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software ;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA
;;; Code: ;;; Code:
(define-module (language elisp runtime macro-slot) (define-module (language elisp runtime macro-slot)
#:use-module (language elisp runtime)) #:use-module (language elisp runtime))
; This module contains the macro definitions of elisp symbols. In contrast to ;;; This module contains the macro definitions of elisp symbols. In
; the other runtime modules, those are used directly during compilation, of ;;; contrast to the other runtime modules, those are used directly
; course, so not really in runtime. But I think it fits well to the others ;;; during compilation, of course, so not really in runtime. But I think
; here. ;;; it fits well to the others here.
; The prog1 and prog2 constructs can easily be defined as macros using progn ;;; The prog1 and prog2 constructs can easily be defined as macros using
; and some lexical-let's to save the intermediate value to return at the end. ;;; progn and some lexical-let's to save the intermediate value to
;;; return at the end.
(built-in-macro prog1 (built-in-macro prog1
(lambda (form1 . rest) (lambda (form1 . rest)
@ -41,7 +43,7 @@
(lambda (form1 form2 . rest) (lambda (form1 form2 . rest)
`(progn ,form1 (prog1 ,form2 ,@rest)))) `(progn ,form1 (prog1 ,form2 ,@rest))))
; Define the conditionals when and unless as macros. ;;; Define the conditionals when and unless as macros.
(built-in-macro when (built-in-macro when
(lambda (condition . thens) (lambda (condition . thens)
@ -51,9 +53,10 @@
(lambda (condition . elses) (lambda (condition . elses)
`(if ,condition nil (progn ,@elses)))) `(if ,condition nil (progn ,@elses))))
; Impement the cond form as nested if's. A special case is a (condition) ;;; Impement the cond form as nested if's. A special case is a
; subform, in which case we need to return the condition itself if it is true ;;; (condition) subform, in which case we need to return the condition
; and thus save it in a local variable before testing it. ;;; itself if it is true and thus save it in a local variable before
;;; testing it.
(built-in-macro cond (built-in-macro cond
(lambda (. clauses) (lambda (. clauses)
@ -77,7 +80,7 @@
(progn ,@(cdr cur)) (progn ,@(cdr cur))
,rest)))))))) ,rest))))))))
; The and and or forms can also be easily defined with macros. ;;; The and and or forms can also be easily defined with macros.
(built-in-macro and (built-in-macro and
(case-lambda (case-lambda
@ -107,7 +110,7 @@
,var ,var
,(iterate (car tail) (cdr tail))))))))))) ,(iterate (car tail) (cdr tail)))))))))))
; Define the dotimes and dolist iteration macros. ;;; Define the dotimes and dolist iteration macros.
(built-in-macro dotimes (built-in-macro dotimes
(lambda (args . body) (lambda (args . body)
@ -150,15 +153,15 @@
(list (caddr args)) (list (caddr args))
'()))))))))) '())))))))))
; Exception handling. unwind-protect and catch are implemented as macros (throw ;;; Exception handling. unwind-protect and catch are implemented as
; is a built-in function). ;;; macros (throw is a built-in function).
; catch and throw can mainly be implemented directly using Guile's ;;; catch and throw can mainly be implemented directly using Guile's
; primitives for exceptions, the only difficulty is that the keys used ;;; primitives for exceptions, the only difficulty is that the keys used
; within Guile must be symbols, while elisp allows any value and checks ;;; within Guile must be symbols, while elisp allows any value and
; for matches using eq (eq?). We handle this by using always #t as key ;;; checks for matches using eq (eq?). We handle this by using always #t
; for the Guile primitives and check for matches inside the handler; if ;;; as key for the Guile primitives and check for matches inside the
; the elisp keys are not eq?, we rethrow the exception. ;;; handler; if the elisp keys are not eq?, we rethrow the exception.
(built-in-macro catch (built-in-macro catch
(lambda (tag . body) (lambda (tag . body)
@ -180,8 +183,8 @@
((guile-primitive throw) ,dummy-key ,elisp-key ((guile-primitive throw) ,dummy-key ,elisp-key
,value)))))))))) ,value))))))))))
; unwind-protect is just some weaker construct as dynamic-wind, so ;;; unwind-protect is just some weaker construct as dynamic-wind, so
; straight-forward to implement. ;;; straight-forward to implement.
(built-in-macro unwind-protect (built-in-macro unwind-protect
(lambda (body . clean-ups) (lambda (body . clean-ups)
@ -192,7 +195,7 @@
(lambda () ,body) (lambda () ,body)
(lambda () ,@clean-ups)))) (lambda () ,@clean-ups))))
; Pop off the first element from a list or push one to it. ;;; Pop off the first element from a list or push one to it.
(built-in-macro pop (built-in-macro pop
(lambda (list-name) (lambda (list-name)

19
module/language/elisp/runtime/value-slot.scm
View file

@ -2,22 +2,23 @@
;;; Copyright (C) 2009 Free Software Foundation, Inc. ;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or modify
;;; modify it under the terms of the GNU Lesser General Public ;;; it under the terms of the GNU Lesser General Public License as
;;; License as published by the Free Software Foundation; either ;;; published by the Free Software Foundation; either version 3 of the
;;; version 3 of the License, or (at your option) any later version. ;;; License, or (at your option) any later version.
;;; ;;;
;;; This library is distributed in the hope that it will be useful, ;;; This library is distributed in the hope that it will be useful, but
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; ;;;
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software ;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA
;;; Code: ;;; Code:
(define-module (language elisp runtime value-slot)) (define-module (language elisp runtime value-slot))
; This module contains the value-slots of elisp symbols. ;;; This module contains the value-slots of elisp symbols.