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

reindent

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/spec.scm: Reindent.

Signed-off-by: Andy Wingo <wingo@pobox.com>
This commit is contained in:
Brian Templeton 2010-06-07 16:38:23 -04:00 • committed by Andy Wingo
parent c983a199d8
commit f4e5e4114d
8 changed files with 1030 additions and 808 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -20,8 +20,10 @@
(define-module (language elisp bindings)
#:export (make-bindings
mark-global-needed! map-globals-needed
with-lexical-bindings with-dynamic-bindings
mark-global-needed!
map-globals-needed
with-lexical-bindings
with-dynamic-bindings
get-lexical-binding))
;;; This module defines routines to handle analysis of symbol bindings
@ -40,8 +42,7 @@
;;; Record type used to hold the data necessary.
(define bindings-type
(make-record-type 'bindings
'(needed-globals lexical-bindings)))
(make-record-type 'bindings '(needed-globals lexical-bindings)))
;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation.
@ -53,45 +54,50 @@
;;; slot-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))
(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)))
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)))
((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 ((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))))))))))
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))))))))))
;;; 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 ((record-accessor bindings-type 'lexical-bindings)
bindings))
(slot (hash-ref lex sym #f)))
(if slot
(fluid-ref slot)
#f)))
(fluid-ref slot)
#f)))
;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.
@ -99,25 +105,25 @@
(define (with-symbol-bindings bindings syms targets proc)
(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)))
(error "can't bind non-symbols" syms))
(let ((lex ((record-accessor bindings-type 'lexical-bindings)
bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
(hash-set! lex sym (make-fluid))))
(hash-set! lex sym (make-fluid))))
syms)
(with-fluids* (map (lambda (sym)
(hash-ref lex sym))
syms)
(with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
targets
proc)))
(define (with-lexical-bindings bindings syms targets proc)
(if (or (not (list? targets))
(not (and-map symbol? targets)))
(error "invalid targets for lexical binding" targets)
(with-symbol-bindings bindings syms targets proc)))
(error "invalid targets for lexical binding" targets)
(with-symbol-bindings bindings syms targets proc)))
(define (with-dynamic-bindings bindings syms proc)
(with-symbol-bindings bindings
syms (map (lambda (el) #f) syms)
syms
(map (lambda (el) #f) syms)
proc))

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

File diff suppressed because it is too large Load diff

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

@ -60,8 +60,8 @@
(define (real-character chr)
(if (< chr 256)
(integer->char chr)
#\nul))
(integer->char chr)
#\nul))
;;; Return the control modified version of a character. This is not
;;; just setting a modifier bit, because ASCII conrol characters must be
@ -71,11 +71,11 @@
(define (add-control chr)
(let ((real (real-character chr)))
(if (char-alphabetic? real)
(- (char->integer (char-upcase real)) (char->integer #\@))
(case real
((#\?) 127)
((#\@) 0)
(else (set-char-bit chr 26))))))
(- (char->integer (char-upcase real)) (char->integer #\@))
(case real
((#\?) 127)
((#\@) 0)
(else (set-char-bit chr 26))))))
;;; Parse a charcode given in some base, basically octal or hexadecimal
;;; are needed. A requested number of digits can be given (#f means it
@ -88,26 +88,29 @@
(let iterate ((result 0)
(procdigs 0))
(if (and digits (>= procdigs digits))
result
(let* ((cur (read-char port))
(value (cond
((char-numeric? cur)
(- (char->integer cur) (char->integer #\0)))
((char-alphabetic? cur)
(let ((code (- (char->integer (char-upcase cur))
(char->integer #\A))))
(if (< code 0)
#f
(+ code 10))))
(else #f)))
(valid (and value (< value base))))
(if (not valid)
(if (or (not digits) early-return)
(begin
(unread-char cur port)
result)
(lexer-error port "invalid digit in escape-code" base cur))
(iterate (+ (* result base) value) (1+ procdigs)))))))
result
(let* ((cur (read-char port))
(value (cond
((char-numeric? cur)
(- (char->integer cur) (char->integer #\0)))
((char-alphabetic? cur)
(let ((code (- (char->integer (char-upcase cur))
(char->integer #\A))))
(if (< code 0)
#f
(+ code 10))))
(else #f)))
(valid (and value (< value base))))
(if (not valid)
(if (or (not digits) early-return)
(begin
(unread-char cur port)
result)
(lexer-error port
"invalid digit in escape-code"
base
cur))
(iterate (+ (* result base) value) (1+ procdigs)))))))
;;; Read a character and process escape-sequences when necessary. The
;;; special in-string argument defines if this character is part of a
@ -116,53 +119,63 @@
;;; characters.
(define basic-escape-codes
'((#\a . 7) (#\b . 8) (#\t . 9)
(#\n . 10) (#\v . 11) (#\f . 12) (#\r . 13)
(#\e . 27) (#\s . 32) (#\d . 127)))
'((#\a . 7)
(#\b . 8)
(#\t . 9)
(#\n . 10)
(#\v . 11)
(#\f . 12)
(#\r . 13)
(#\e . 27)
(#\s . 32)
(#\d . 127)))
(define (get-character port in-string)
(let ((meta-bits `((#\A . 22) (#\s . 23) (#\H . 24)
(#\S . 25) (#\M . ,(if in-string 7 27))))
(let ((meta-bits `((#\A . 22)
(#\s . 23)
(#\H . 24)
(#\S . 25)
(#\M . ,(if in-string 7 27))))
(cur (read-char port)))
(if (char=? cur #\\)
;; Handle an escape-sequence.
(let* ((escaped (read-char port))
(esc-code (assq-ref basic-escape-codes escaped))
(meta (assq-ref meta-bits escaped)))
(cond
;; Meta-check must be before esc-code check because \s- must
;; be recognized as the super-meta modifier if a - follows.
;; If not, it will be caught as \s -> space escape code.
((and meta (is-char? (peek-char port) #\-))
(if (not (char=? (read-char port) #\-))
(error "expected - after control sequence"))
(set-char-bit (get-character port in-string) meta))
;; One of the basic control character escape names?
(esc-code esc-code)
;; Handle \ddd octal code if it is one.
((and (char>=? escaped #\0) (char<? escaped #\8))
(begin
(unread-char escaped port)
(charcode-escape port 8 3 #t)))
;; Check for some escape-codes directly or otherwise use the
;; escaped character literally.
(else
;; Handle an escape-sequence.
(let* ((escaped (read-char port))
(esc-code (assq-ref basic-escape-codes escaped))
(meta (assq-ref meta-bits escaped)))
(cond
;; Meta-check must be before esc-code check because \s- must
;; be recognized as the super-meta modifier if a - follows.
;; If not, it will be caught as \s -> space escape code.
((and meta (is-char? (peek-char port) #\-))
(if (not (char=? (read-char port) #\-))
(error "expected - after control sequence"))
(set-char-bit (get-character port in-string) meta))
;; One of the basic control character escape names?
(esc-code esc-code)
;; Handle \ddd octal code if it is one.
((and (char>=? escaped #\0) (char<? escaped #\8))
(begin
(unread-char escaped port)
(charcode-escape port 8 3 #t)))
;; Check for some escape-codes directly or otherwise use the
;; escaped character literally.
(else
(case escaped
((#\^) (add-control (get-character port in-string)))
((#\C)
(if (is-char? (peek-char port) #\-)
(begin
(if (not (char=? (read-char port) #\-))
(error "expected - after control sequence"))
(add-control (get-character port in-string)))
escaped))
(begin
(if (not (char=? (read-char port) #\-))
(error "expected - after control sequence"))
(add-control (get-character port in-string)))
escaped))
((#\x) (charcode-escape port 16 #f #t))
((#\u) (charcode-escape port 16 4 #f))
((#\U) (charcode-escape port 16 8 #f))
(else (char->integer escaped))))))
;; No escape-sequence, just the literal character.
;; But remember to get the code instead!
(char->integer cur))))
;; No escape-sequence, just the literal character. But remember
;; to get the code instead!
(char->integer cur))))
;;; Read a symbol or number from a port until something follows that
;;; marks the start of a new token (like whitespace or parentheses).
@ -176,7 +189,8 @@
(define integer-regex (make-regexp "^[+-]?[0-9]+\\.?$"))
(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 'dot' terminal for dotted lists.
@ -188,29 +202,31 @@
(had-escape #f))
(let* ((c (read-char port))
(finish (lambda ()
(let ((result (list->string (reverse result-chars))))
(let ((result (list->string
(reverse result-chars))))
(values
(cond
((and (not had-escape)
(regexp-exec integer-regex result))
'integer)
((and (not had-escape)
(regexp-exec float-regex result))
'float)
(else 'symbol))
result))))
(cond
((and (not had-escape)
(regexp-exec integer-regex result))
'integer)
((and (not had-escape)
(regexp-exec float-regex result))
'float)
(else 'symbol))
result))))
(need-no-escape? (lambda (c)
(or (char-numeric? c)
(char-alphabetic? c)
(char-set-contains? no-escape-punctuation
c)))))
(char-set-contains?
no-escape-punctuation
c)))))
(cond
((eof-object? c) (finish))
((need-no-escape? c) (iterate (cons c result-chars) had-escape))
((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
(else
(unread-char c port)
(finish))))))
((eof-object? c) (finish))
((need-no-escape? c) (iterate (cons c result-chars) had-escape))
((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
(else
(unread-char c port)
(finish))))))
;;; Parse a circular structure marker without the leading # (which was
;;; already read and recognized), that is, a number as identifier and
@ -218,24 +234,28 @@
(define (get-circular-marker port)
(call-with-values
(lambda ()
(let iterate ((result 0))
(let ((cur (read-char port)))
(if (char-numeric? cur)
(let ((val (- (char->integer cur) (char->integer #\0))))
(iterate (+ (* result 10) val)))
(values result cur)))))
(lambda ()
(let iterate ((result 0))
(let ((cur (read-char port)))
(if (char-numeric? cur)
(let ((val (- (char->integer cur) (char->integer #\0))))
(iterate (+ (* result 10) val)))
(values result cur)))))
(lambda (id type)
(case type
((#\#) `(circular-ref . ,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.
(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))
(line (1+ (port-line port)))
(column (1+ (port-column port))))
(lambda (token value)
@ -248,114 +268,116 @@
;; and actually point to the very character to be read.
(c (read-char port)))
(cond
;; End of input must be specially marked to the parser.
((eof-object? c) '*eoi*)
;; Whitespace, just skip it.
((char-whitespace? c) (lex port))
;; The dot is only the one for dotted lists if followed by
;; whitespace. Otherwise it is considered part of a number of
;; symbol.
((and (char=? c #\.)
(char-whitespace? (peek-char port)))
(return 'dot #f))
;; Continue checking for literal character values.
(else
(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))
;; End of input must be specially marked to the parser.
((eof-object? c) '*eoi*)
;; Whitespace, just skip it.
((char-whitespace? c) (lex port))
;; The dot is only the one for dotted lists if followed by
;; whitespace. Otherwise it is considered part of a number of
;; symbol.
((and (char=? c #\.)
(char-whitespace? (peek-char port)))
(return 'dot #f))
;; Continue checking for literal character values.
(else
(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)))))
;; A character literal.
((#\?)
(return 'character (get-character port #f)))
;; A literal string. This is mainly a sequence of characters
;; just as in the character literals, the only difference is
;; that escaped newline and space are to be completely ignored
;; and that meta-escapes set bit 7 rather than bit 27.
((#\")
(let iterate ((result-chars '()))
(let ((cur (read-char port)))
(case cur
((#\")
(return 'string (list->string (reverse result-chars))))
((#\\)
(let ((escaped (read-char port)))
(case escaped
((#\newline #\space)
(iterate result-chars))
(else
(unread-char escaped port)
(unread-char cur port)
(iterate (cons (integer->char (get-character port #t))
result-chars))))))
(else (iterate (cons cur result-chars)))))))
;; Circular markers (either reference or definition).
((#\#)
(let ((mark (get-circular-marker port)))
(return (car mark) (cdr mark))))
;; Parentheses and other special-meaning single characters.
((#\() (return 'paren-open #f))
((#\)) (return 'paren-close #f))
((#\[) (return 'square-open #f))
((#\]) (return 'square-close #f))
((#\') (return 'quote #f))
((#\`) (return 'backquote #f))
;; Unquote and unquote-splicing.
((#\,)
(if (is-char? (peek-char port) #\@)
;; A character literal.
((#\?)
(return 'character (get-character port #f)))
;; A literal string. This is mainly a sequence of characters
;; just as in the character literals, the only difference is
;; that escaped newline and space are to be completely ignored
;; and that meta-escapes set bit 7 rather than bit 27.
((#\")
(let iterate ((result-chars '()))
(let ((cur (read-char port)))
(case cur
((#\")
(return 'string (list->string (reverse result-chars))))
((#\\)
(let ((escaped (read-char port)))
(case escaped
((#\newline #\space)
(iterate result-chars))
(else
(unread-char escaped port)
(unread-char cur port)
(iterate
(cons (integer->char (get-character port #t))
result-chars))))))
(else (iterate (cons cur result-chars)))))))
;; Circular markers (either reference or definition).
((#\#)
(let ((mark (get-circular-marker port)))
(return (car mark) (cdr mark))))
;; Parentheses and other special-meaning single characters.
((#\() (return 'paren-open #f))
((#\)) (return 'paren-close #f))
((#\[) (return 'square-open #f))
((#\]) (return 'square-close #f))
((#\') (return 'quote #f))
((#\`) (return 'backquote #f))
;; Unquote and unquote-splicing.
((#\,)
(if (is-char? (peek-char port) #\@)
(if (not (char=? (read-char port) #\@))
(error "expected @ in unquote-splicing")
(return 'unquote-splicing #f))
(error "expected @ in unquote-splicing")
(return 'unquote-splicing #f))
(return 'unquote #f)))
;; Remaining are numbers and symbols. Process input until next
;; whitespace is found, and see if it looks like a number
;; (float/integer) or symbol and return accordingly.
(else
(unread-char c port)
(call-with-values
(lambda ()
(get-symbol-or-number port))
(lambda (type str)
(case type
((symbol)
;; str could be empty if the first character is
;; already something not allowed in a symbol (and not
;; escaped)! Take care about that, it is an error
;; because that character should have been handled
;; elsewhere or is invalid in the input.
(if (zero? (string-length str))
(begin
;; Take it out so the REPL might not get into an
;; infinite loop with further reading attempts.
(read-char port)
(error "invalid character in input" c))
(return 'symbol (string->symbol str))))
((integer)
;; In elisp, something like "1." is an integer, while
;; string->number returns an inexact real. Thus we
;; need a conversion here, but it should always
;; result in an integer!
(return 'integer
(let ((num (inexact->exact (string->number str))))
(if (not (integer? num))
(error "expected integer" str num))
num)))
((float)
(return 'float (let ((num (string->number str)))
(if (exact? num)
(error "expected inexact float" str num))
num)))
(else (error "wrong number/symbol type" type)))))))))))
;; Remaining are numbers and symbols. Process input until next
;; whitespace is found, and see if it looks like a number
;; (float/integer) or symbol and return accordingly.
(else
(unread-char c port)
(call-with-values
(lambda () (get-symbol-or-number port))
(lambda (type str)
(case type
((symbol)
;; str could be empty if the first character is already
;; something not allowed in a symbol (and not escaped)!
;; Take care about that, it is an error because that
;; character should have been handled elsewhere or is
;; invalid in the input.
(if (zero? (string-length str))
(begin
;; Take it out so the REPL might not get into an
;; infinite loop with further reading attempts.
(read-char port)
(error "invalid character in input" c))
(return 'symbol (string->symbol str))))
((integer)
;; In elisp, something like "1." is an integer, while
;; string->number returns an inexact real. Thus we need
;; a conversion here, but it should always result in an
;; integer!
(return
'integer
(let ((num (inexact->exact (string->number str))))
(if (not (integer? num))
(error "expected integer" str num))
num)))
((float)
(return 'float (let ((num (string->number str)))
(if (exact? num)
(error "expected inexact float"
str
num))
num)))
(else (error "wrong number/symbol type" type)))))))))))
;;; Build a lexer thunk for a port. This is the exported routine which
;;; can be used to create a lexer for the parser to use.
(define (get-lexer port)
(lambda ()
(lex port)))
(lambda () (lex port)))
;;; Build a special lexer that will only read enough for one expression
;;; and then always return end-of-input. If we find one of the quotation
@ -367,16 +389,16 @@
(paren-level 0))
(lambda ()
(if finished
'*eoi*
(let ((next (lex))
(quotation #f))
(case (car next)
((paren-open square-open)
(set! paren-level (1+ paren-level)))
((paren-close square-close)
(set! paren-level (1- paren-level)))
((quote backquote unquote unquote-splicing circular-def)
(set! quotation #t)))
(if (and (not quotation) (<= paren-level 0))
(set! finished #t))
next)))))
'*eoi*
(let ((next (lex))
(quotation #f))
(case (car next)
((paren-open square-open)
(set! paren-level (1+ paren-level)))
((paren-close square-close)
(set! paren-level (1- paren-level)))
((quote backquote unquote unquote-splicing circular-def)
(set! quotation #t)))
(if (and (not quotation) (<= paren-level 0))
(set! finished #t))
next)))))

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

@ -54,12 +54,12 @@
(define (circular-ref token)
(if (not (eq? (car token) 'circular-ref))
(error "invalid token for circular-ref" token))
(error "invalid token for circular-ref" token))
(let* ((id (cdr token))
(value (hashq-ref (fluid-ref circular-definitions) id)))
(if value
value
(parse-error token "undefined circular reference" id))))
value
(parse-error token "undefined circular reference" id))))
;;; Returned is a closure that, when invoked, will set the final value.
;;; This means both the variable the promise will return and the
@ -67,7 +67,7 @@
(define (circular-define! token)
(if (not (eq? (car token) 'circular-def))
(error "invalid token for circular-define!" token))
(error "invalid token for circular-define!" token))
(let ((value #f)
(table (fluid-ref circular-definitions))
(id (cdr token)))
@ -85,25 +85,25 @@
(define (force-promises! data)
(cond
((pair? data)
(begin
(if (promise? (car data))
(set-car! data (force (car data)))
(force-promises! (car data)))
(if (promise? (cdr data))
(set-cdr! data (force (cdr data)))
(force-promises! (cdr data)))))
((vector? data)
(let ((len (vector-length data)))
(let iterate ((i 0))
(if (< i len)
(let ((el (vector-ref data i)))
(if (promise? el)
(vector-set! data i (force el))
(force-promises! el))
(iterate (1+ i)))))))
;; Else nothing needs to be done.
))
((pair? data)
(begin
(if (promise? (car data))
(set-car! data (force (car data)))
(force-promises! (car data)))
(if (promise? (cdr data))
(set-cdr! data (force (cdr data)))
(force-promises! (cdr data)))))
((vector? data)
(let ((len (vector-length data)))
(let iterate ((i 0))
(if (< i len)
(let ((el (vector-ref data i)))
(if (promise? el)
(vector-set! data i (force el))
(force-promises! el))
(iterate (1+ i)))))))
;; Else nothing needs to be done.
))
;;; We need peek-functionality for the next lexer token, this is done
;;; with some single token look-ahead storage. This is handled by a
@ -116,19 +116,19 @@
(let ((look-ahead #f))
(lambda (action)
(if (eq? action 'finish)
(if look-ahead
(error "lexer-buffer is not empty when finished")
#f)
(begin
(if (not look-ahead)
(set! look-ahead (lex)))
(case action
((peek) look-ahead)
((get)
(let ((result look-ahead))
(set! look-ahead #f)
result))
(else (error "invalid lexer-buffer action" action))))))))
(if look-ahead
(error "lexer-buffer is not empty when finished")
#f)
(begin
(if (not look-ahead)
(set! look-ahead (lex)))
(case action
((peek) look-ahead)
((get)
(let ((result look-ahead))
(set! look-ahead #f)
result))
(else (error "invalid lexer-buffer action" action))))))))
;;; Get the contents of a list, where the opening parentheses has
;;; already been found. The same code is used for vectors and lists,
@ -141,24 +141,25 @@
(let* ((next (lex 'peek))
(type (car next)))
(cond
((eq? type (if close-square 'square-close 'paren-close))
(begin
(if (not (eq? (car (lex 'get)) type))
(error "got different token than peeked"))
'()))
((and allow-dot (eq? type 'dot))
(begin
(if (not (eq? (car (lex 'get)) type))
(error "got different token than peeked"))
(let ((tail (get-list lex #f close-square)))
(if (not (= (length tail) 1))
(parse-error next "expected exactly one element after dot"))
(car tail))))
(else
;; Do both parses in exactly this sequence!
(let* ((head (get-expression lex))
(tail (get-list lex allow-dot close-square)))
(cons head tail))))))
((eq? type (if close-square 'square-close 'paren-close))
(begin
(if (not (eq? (car (lex 'get)) type))
(error "got different token than peeked"))
'()))
((and allow-dot (eq? type 'dot))
(begin
(if (not (eq? (car (lex 'get)) type))
(error "got different token than peeked"))
(let ((tail (get-list lex #f close-square)))
(if (not (= (length tail) 1))
(parse-error next
"expected exactly one element after dot"))
(car tail))))
(else
;; Do both parses in exactly this sequence!
(let* ((head (get-expression lex))
(tail (get-list lex allow-dot close-square)))
(cons head tail))))))
;;; Parse a single expression from a lexer-buffer. This is the main
;;; routine in our recursive-descent parser.
@ -173,13 +174,16 @@
(type (car token))
(return (lambda (result)
(if (pair? result)
(set-source-properties! result (source-properties token)))
(set-source-properties!
result
(source-properties token)))
result)))
(case type
((integer float symbol character string)
(return (cdr token)))
((quote backquote unquote unquote-splicing)
(return (list (assq-ref quotation-symbols type) (get-expression lex))))
(return (list (assq-ref quotation-symbols type)
(get-expression lex))))
((paren-open)
(return (get-list lex #t #f)))
((square-open)
@ -194,7 +198,7 @@
(force-promises! expr)
expr))
(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, and then parse a single expression to return. We also

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

@ -20,12 +20,17 @@
(define-module (language elisp runtime)
#:export (void
nil-value t-value
value-slot-module function-slot-module
nil-value
t-value
value-slot-module
function-slot-module
elisp-bool
ensure-fluid! reference-variable reference-variable-with-check
ensure-fluid!
reference-variable
reference-variable-with-check
set-variable!
runtime-error macro-error)
runtime-error
macro-error)
#:export-syntax (built-in-func built-in-macro prim))
;;; This module provides runtime support for the Elisp front-end.
@ -61,8 +66,8 @@
(define (elisp-bool b)
(if b
t-value
nil-value))
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,
@ -74,10 +79,10 @@
(let ((intf (resolve-interface module))
(resolved (resolve-module module)))
(if (not (module-defined? intf sym))
(let ((fluid (make-fluid)))
(fluid-set! fluid void)
(module-define! resolved sym fluid)
(module-export! resolved `(,sym))))))
(let ((fluid (make-fluid)))
(fluid-set! fluid void)
(module-define! resolved sym fluid)
(module-export! resolved `(,sym))))))
(define (reference-variable module sym)
(ensure-fluid! module sym)
@ -87,8 +92,8 @@
(define (reference-variable-with-check module sym)
(let ((value (reference-variable module sym)))
(if (eq? value void)
(runtime-error "variable is void:" sym)
value)))
(runtime-error "variable is void:" sym)
value)))
(define (set-variable! module sym value)
(ensure-fluid! module sym)

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

@ -28,68 +28,85 @@
;;; Equivalence and equalness predicates.
(built-in-func eq (lambda (a b)
(elisp-bool (eq? a b))))
(built-in-func eq
(lambda (a b)
(elisp-bool (eq? a b))))
(built-in-func equal (lambda (a b)
(elisp-bool (equal? 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 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 integerp
(lambda (num)
(elisp-bool (and (exact? num)
(integer? num)))))
(built-in-func numberp (lambda (num)
(elisp-bool (real? 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 wholenump
(lambda (num)
(elisp-bool (and (exact? num)
(integer? num)
(prim >= num 0)))))
(built-in-func zerop (lambda (num)
(elisp-bool (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 = num1 num2))))
(built-in-func /= (lambda (num1 num2)
(elisp-bool (prim not (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 > (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 max
(lambda (. nums)
(prim apply (@ (guile) max) nums)))
(built-in-func min (lambda (. nums)
(prim apply (@ (guile) min) nums)))
(built-in-func min
(lambda (. nums)
(prim apply (@ (guile) min) nums)))
(built-in-func abs (@ (guile) abs))
(built-in-func abs
(@ (guile) abs))
;;; Number conversion.
(built-in-func float (lambda (num)
(if (exact? num)
(exact->inexact num)
num)))
(built-in-func float
(lambda (num)
(if (exact? num)
(exact->inexact num)
num)))
;;; TODO: truncate, floor, ceiling, round.
@ -148,48 +165,48 @@
(built-in-func car
(lambda (el)
(if (null? el)
nil-value
(prim car el))))
nil-value
(prim car el))))
(built-in-func cdr
(lambda (el)
(if (null? el)
nil-value
(prim cdr el))))
nil-value
(prim cdr el))))
(built-in-func car-safe
(lambda (el)
(if (pair? el)
(prim car el)
nil-value)))
(prim car el)
nil-value)))
(built-in-func cdr-safe
(lambda (el)
(if (pair? el)
(prim cdr el)
nil-value)))
(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))))))))
(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))))))))
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))
@ -212,31 +229,36 @@
(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)))))))))))
(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.
@ -281,12 +303,16 @@
(built-in-func boundp
(lambda (sym)
(elisp-bool (prim not
(eq? void (reference-variable value-slot-module sym))))))
(eq? void
(reference-variable value-slot-module
sym))))))
(built-in-func fboundp
(lambda (sym)
(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 or raw lambda-lists as functions!
@ -294,15 +320,17 @@
(built-in-func apply
(lambda (func . args)
(let ((real-func (cond
((symbol? func)
(reference-variable-with-check 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))))
((symbol? func)
(reference-variable-with-check
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

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

@ -61,23 +61,23 @@
(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)))
`(without-void-checks (,var)
(lexical-let ((,var ,(car cur)))
(if ,var
,var
,rest)))))
(else
`(if ,(car cur)
(progn ,@(cdr cur))
,rest))))))))
'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)))
`(without-void-checks (,var)
(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.
@ -103,54 +103,56 @@
x
(let ((var (gensym)))
`(without-void-checks
(,var)
(lexical-let ((,var ,x))
(if ,var
,var
,(iterate (car tail) (cdr tail)))))))))))
(,var)
(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))
'()))))))
(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)
(without-void-checks (,tailvar)
(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))
'())))))))))
(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)
(without-void-checks (,tailvar)
(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).
@ -165,22 +167,23 @@
(built-in-macro catch
(lambda (tag . body)
(if (null? body)
(macro-error "catch with empty 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)
#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))))))))))
,value))))))))))
;;; unwind-protect is just some weaker construct as dynamic-wind, so
;;; straight-forward to implement.
@ -188,11 +191,11 @@
(built-in-macro unwind-protect
(lambda (body . clean-ups)
(if (null? clean-ups)
(macro-error "unwind-protect without cleanup code"))
(macro-error "unwind-protect without cleanup code"))
`((guile-primitive dynamic-wind)
(lambda () nil)
(lambda () ,body)
(lambda () ,@clean-ups))))
(lambda () nil)
(lambda () ,body)
(lambda () ,@clean-ups))))
;;; Pop off the first element from a list or push one to it.

8
module/language/elisp/spec.scm
View file

@ -25,7 +25,7 @@
#:export (elisp))
(define-language elisp
#:title "Emacs Lisp"
#:reader (lambda (port env) (read-elisp port))
#:printer write
#:compilers `((tree-il . ,compile-tree-il)))
#:title "Emacs Lisp"
#:reader (lambda (port env) (read-elisp port))
#:printer write
#:compilers `((tree-il . ,compile-tree-il)))