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

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) (define-module (language elisp bindings)
#:export (make-bindings #:export (make-bindings
mark-global-needed! map-globals-needed mark-global-needed!
with-lexical-bindings with-dynamic-bindings map-globals-needed
with-lexical-bindings
with-dynamic-bindings
get-lexical-binding)) get-lexical-binding))
;;; This module defines routines to handle analysis of symbol bindings ;;; This module defines routines to handle analysis of symbol bindings
@ -40,8 +42,7 @@
;;; Record type used to hold the data necessary. ;;; 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 ;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation. ;;; used at the start of a fresh compilation.
@ -53,45 +54,50 @@
;;; slot-module. ;;; 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))
(old-in-module (or (assoc-ref old-needed module) '())) (old-in-module (or (assoc-ref old-needed module) '()))
(new-in-module (if (memq sym old-in-module) (new-in-module (if (memq sym old-in-module)
old-in-module old-in-module
(cons sym old-in-module))) (cons sym old-in-module)))
(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 ;;; Cycle through all globals needed in order to generate the code for
;;; their 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)))
(let iterate-modules ((mod-tail needed) (let iterate-modules ((mod-tail needed)
(mod-result '())) (mod-result '()))
(if (null? mod-tail) (if (null? mod-tail)
mod-result mod-result
(iterate-modules (iterate-modules
(cdr mod-tail) (cdr mod-tail)
(let* ((aentry (car mod-tail)) (let* ((aentry (car mod-tail))
(module (car aentry)) (module (car aentry))
(symbols (cdr aentry))) (symbols (cdr aentry)))
(let iterate-symbols ((sym-tail symbols) (let iterate-symbols ((sym-tail symbols)
(sym-result mod-result)) (sym-result mod-result))
(if (null? sym-tail) (if (null? sym-tail)
sym-result sym-result
(iterate-symbols (cdr sym-tail) (iterate-symbols (cdr sym-tail)
(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 ;;; Get the current lexical binding (gensym it should refer to in the
;;; current 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))
(slot (hash-ref lex sym #f))) (slot (hash-ref lex sym #f)))
(if slot (if slot
(fluid-ref slot) (fluid-ref slot)
#f))) #f)))
;;; Establish a binding or mark a symbol as dynamically bound for the ;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc. ;;; extent of calling proc.
@ -99,25 +105,25 @@
(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))
(not (and-map symbol? syms))) (not (and-map symbol? syms)))
(error "can't bind non-symbols" syms)) (error "can't bind non-symbols" syms))
(let ((lex ((record-accessor bindings-type 'lexical-bindings) bindings))) (let ((lex ((record-accessor bindings-type 'lexical-bindings)
bindings)))
(for-each (lambda (sym) (for-each (lambda (sym)
(if (not (hash-ref lex sym)) (if (not (hash-ref lex sym))
(hash-set! lex sym (make-fluid)))) (hash-set! lex sym (make-fluid))))
syms) syms)
(with-fluids* (map (lambda (sym) (with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
(hash-ref lex sym))
syms)
targets targets
proc))) proc)))
(define (with-lexical-bindings bindings syms targets proc) (define (with-lexical-bindings bindings syms targets proc)
(if (or (not (list? targets)) (if (or (not (list? targets))
(not (and-map symbol? targets))) (not (and-map symbol? targets)))
(error "invalid targets for lexical binding" targets) (error "invalid targets for lexical binding" targets)
(with-symbol-bindings bindings syms targets proc))) (with-symbol-bindings bindings syms targets proc)))
(define (with-dynamic-bindings bindings syms proc) (define (with-dynamic-bindings bindings syms proc)
(with-symbol-bindings bindings (with-symbol-bindings bindings
syms (map (lambda (el) #f) syms) syms
(map (lambda (el) #f) syms)
proc)) 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) (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 ;;; Return the control modified version of a character. This is not
;;; just setting a modifier bit, because ASCII conrol characters must be ;;; just setting a modifier bit, because ASCII conrol characters must be
@ -71,11 +71,11 @@
(define (add-control chr) (define (add-control chr)
(let ((real (real-character chr))) (let ((real (real-character chr)))
(if (char-alphabetic? real) (if (char-alphabetic? real)
(- (char->integer (char-upcase real)) (char->integer #\@)) (- (char->integer (char-upcase real)) (char->integer #\@))
(case real (case real
((#\?) 127) ((#\?) 127)
((#\@) 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 ;;; Parse a charcode given in some base, basically octal or hexadecimal
;;; are needed. A requested number of digits can be given (#f means it ;;; are needed. A requested number of digits can be given (#f means it
@ -88,26 +88,29 @@
(let iterate ((result 0) (let iterate ((result 0)
(procdigs 0)) (procdigs 0))
(if (and digits (>= procdigs digits)) (if (and digits (>= procdigs digits))
result result
(let* ((cur (read-char port)) (let* ((cur (read-char port))
(value (cond (value (cond
((char-numeric? cur) ((char-numeric? cur)
(- (char->integer cur) (char->integer #\0))) (- (char->integer cur) (char->integer #\0)))
((char-alphabetic? cur) ((char-alphabetic? cur)
(let ((code (- (char->integer (char-upcase cur)) (let ((code (- (char->integer (char-upcase cur))
(char->integer #\A)))) (char->integer #\A))))
(if (< code 0) (if (< code 0)
#f #f
(+ code 10)))) (+ code 10))))
(else #f))) (else #f)))
(valid (and value (< value base)))) (valid (and value (< value base))))
(if (not valid) (if (not valid)
(if (or (not digits) early-return) (if (or (not digits) early-return)
(begin (begin
(unread-char cur port) (unread-char cur port)
result) result)
(lexer-error port "invalid digit in escape-code" base cur)) (lexer-error port
(iterate (+ (* result base) value) (1+ procdigs))))))) "invalid digit in escape-code"
base
cur))
(iterate (+ (* result base) value) (1+ procdigs)))))))
;;; Read a character and process escape-sequences when necessary. The ;;; Read a character and process escape-sequences when necessary. The
;;; special in-string argument defines if this character is part of a ;;; special in-string argument defines if this character is part of a
@ -116,53 +119,63 @@
;;; characters. ;;; characters.
(define basic-escape-codes (define basic-escape-codes
'((#\a . 7) (#\b . 8) (#\t . 9) '((#\a . 7)
(#\n . 10) (#\v . 11) (#\f . 12) (#\r . 13) (#\b . 8)
(#\e . 27) (#\s . 32) (#\d . 127))) (#\t . 9)
(#\n . 10)
(#\v . 11)
(#\f . 12)
(#\r . 13)
(#\e . 27)
(#\s . 32)
(#\d . 127)))
(define (get-character port in-string) (define (get-character port in-string)
(let ((meta-bits `((#\A . 22) (#\s . 23) (#\H . 24) (let ((meta-bits `((#\A . 22)
(#\S . 25) (#\M . ,(if in-string 7 27)))) (#\s . 23)
(#\H . 24)
(#\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 ;; Meta-check must be before esc-code check because \s- must
;; be recognized as the super-meta modifier if a - follows. ;; be recognized as the super-meta modifier if a - follows.
;; If not, it will be caught as \s -> space escape code. ;; If 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 use the ;; Check for some escape-codes directly or otherwise 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)))
((#\C) ((#\C)
(if (is-char? (peek-char port) #\-) (if (is-char? (peek-char port) #\-)
(begin (begin
(if (not (char=? (read-char port) #\-)) (if (not (char=? (read-char port) #\-))
(error "expected - after control sequence")) (error "expected - after control sequence"))
(add-control (get-character port in-string))) (add-control (get-character port in-string)))
escaped)) escaped))
((#\x) (charcode-escape port 16 #f #t)) ((#\x) (charcode-escape port 16 #f #t))
((#\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
;; But remember to get the code instead! ;; to get the code instead!
(char->integer cur)))) (char->integer cur))))
;;; Read a symbol or number from a port until something follows that ;;; Read a symbol or number from a port until something follows that
;;; marks the start of a new token (like whitespace or parentheses). ;;; marks the start of a new token (like whitespace or parentheses).
@ -176,7 +189,8 @@
(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 ;;; A dot is also allowed literally, only a single dort alone is parsed
;;; as the 'dot' terminal for dotted lists. ;;; as the 'dot' terminal for dotted lists.
@ -188,29 +202,31 @@
(had-escape #f)) (had-escape #f))
(let* ((c (read-char port)) (let* ((c (read-char port))
(finish (lambda () (finish (lambda ()
(let ((result (list->string (reverse result-chars)))) (let ((result (list->string
(reverse result-chars))))
(values (values
(cond (cond
((and (not had-escape) ((and (not had-escape)
(regexp-exec integer-regex result)) (regexp-exec integer-regex result))
'integer) 'integer)
((and (not had-escape) ((and (not had-escape)
(regexp-exec float-regex result)) (regexp-exec float-regex result))
'float) 'float)
(else 'symbol)) (else 'symbol))
result)))) result))))
(need-no-escape? (lambda (c) (need-no-escape? (lambda (c)
(or (char-numeric? c) (or (char-numeric? c)
(char-alphabetic? c) (char-alphabetic? c)
(char-set-contains? no-escape-punctuation (char-set-contains?
c))))) no-escape-punctuation
c)))))
(cond (cond
((eof-object? c) (finish)) ((eof-object? c) (finish))
((need-no-escape? c) (iterate (cons c result-chars) had-escape)) ((need-no-escape? c) (iterate (cons c result-chars) had-escape))
((char=? c #\\) (iterate (cons (read-char port) result-chars) #t)) ((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
(else (else
(unread-char c port) (unread-char c port)
(finish)))))) (finish))))))
;;; Parse a circular structure marker without the leading # (which was ;;; Parse a circular structure marker without the leading # (which was
;;; already read and recognized), that is, a number as identifier and ;;; already read and recognized), that is, a number as identifier and
@ -218,24 +234,28 @@
(define (get-circular-marker port) (define (get-circular-marker port)
(call-with-values (call-with-values
(lambda () (lambda ()
(let iterate ((result 0)) (let iterate ((result 0))
(let ((cur (read-char port))) (let ((cur (read-char port)))
(if (char-numeric? cur) (if (char-numeric? cur)
(let ((val (- (char->integer cur) (char->integer #\0)))) (let ((val (- (char->integer cur) (char->integer #\0))))
(iterate (+ (* result 10) val))) (iterate (+ (* result 10) val)))
(values result cur))))) (values result cur)))))
(lambda (id type) (lambda (id type)
(case type (case type
((#\#) `(circular-ref . ,id)) ((#\#) `(circular-ref . ,id))
((#\=) `(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 ;;; Main lexer routine, which is given a port and does look for the next
;;; token. ;;; 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))
(line (1+ (port-line port))) (line (1+ (port-line port)))
(column (1+ (port-column port)))) (column (1+ (port-column port))))
(lambda (token value) (lambda (token value)
@ -248,114 +268,116 @@
;; 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 ;; whitespace. Otherwise it is considered part of a number of
;; symbol. ;; 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 ;; A literal string. This is mainly a sequence of characters
;; just as in the character literals, the only difference is ;; just as in the character literals, the only difference is
;; that escaped newline and space are to be completely ignored ;; that escaped newline and space are to be completely ignored
;; and that meta-escapes 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)))
(case cur (case cur
((#\") ((#\")
(return 'string (list->string (reverse result-chars)))) (return 'string (list->string (reverse result-chars))))
((#\\) ((#\\)
(let ((escaped (read-char port))) (let ((escaped (read-char port)))
(case escaped (case escaped
((#\newline #\space) ((#\newline #\space)
(iterate result-chars)) (iterate result-chars))
(else (else
(unread-char escaped port) (unread-char escaped port)
(unread-char cur port) (unread-char cur port)
(iterate (cons (integer->char (get-character port #t)) (iterate
result-chars)))))) (cons (integer->char (get-character port #t))
(else (iterate (cons cur result-chars))))))) result-chars))))))
;; Circular markers (either reference or definition). (else (iterate (cons cur result-chars)))))))
((#\#) ;; Circular markers (either reference or definition).
(let ((mark (get-circular-marker port))) ((#\#)
(return (car mark) (cdr mark)))) (let ((mark (get-circular-marker port)))
;; Parentheses and other special-meaning single characters. (return (car mark) (cdr mark))))
((#\() (return 'paren-open #f)) ;; Parentheses and other special-meaning single characters.
((#\)) (return 'paren-close #f)) ((#\() (return 'paren-open #f))
((#\[) (return 'square-open #f)) ((#\)) (return 'paren-close #f))
((#\]) (return 'square-close #f)) ((#\[) (return 'square-open #f))
((#\') (return 'quote #f)) ((#\]) (return 'square-close #f))
((#\`) (return 'backquote #f)) ((#\') (return 'quote #f))
;; Unquote and unquote-splicing. ((#\`) (return 'backquote #f))
((#\,) ;; 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
(lambda () (lambda () (get-symbol-or-number port))
(get-symbol-or-number port)) (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
;; escaped)! Take care about that, it is an error ;; character should have been handled elsewhere or is
;; because that character should have been handled ;; invalid in the 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 need
;; string->number returns an inexact real. Thus we ;; a conversion here, but it should always result in an
;; need a conversion here, but it should always ;; integer!
;; result in an integer! (return
(return 'integer 'integer
(let ((num (inexact->exact (string->number str)))) (let ((num (inexact->exact (string->number str))))
(if (not (integer? num)) (if (not (integer? num))
(error "expected integer" str num)) (error "expected integer" str num))
num))) num)))
((float) ((float)
(return 'float (let ((num (string->number str))) (return 'float (let ((num (string->number str)))
(if (exact? num) (if (exact? num)
(error "expected inexact float" str num)) (error "expected inexact float"
num))) str
(else (error "wrong number/symbol type" type))))))))))) num))
num)))
(else (error "wrong number/symbol type" type)))))))))))
;;; Build a lexer thunk for a port. This is the exported routine which ;;; 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. ;;; 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 ;;; 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 ;;; and then always return end-of-input. If we find one of the quotation
@ -367,16 +389,16 @@
(paren-level 0)) (paren-level 0))
(lambda () (lambda ()
(if finished (if finished
'*eoi* '*eoi*
(let ((next (lex)) (let ((next (lex))
(quotation #f)) (quotation #f))
(case (car next) (case (car next)
((paren-open square-open) ((paren-open square-open)
(set! paren-level (1+ paren-level))) (set! paren-level (1+ paren-level)))
((paren-close square-close) ((paren-close square-close)
(set! paren-level (1- paren-level))) (set! paren-level (1- paren-level)))
((quote backquote unquote unquote-splicing circular-def) ((quote backquote unquote unquote-splicing circular-def)
(set! quotation #t))) (set! quotation #t)))
(if (and (not quotation) (<= paren-level 0)) (if (and (not quotation) (<= paren-level 0))
(set! finished #t)) (set! finished #t))
next))))) next)))))

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

@ -54,12 +54,12 @@
(define (circular-ref token) (define (circular-ref token)
(if (not (eq? (car token) 'circular-ref)) (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)) (let* ((id (cdr token))
(value (hashq-ref (fluid-ref circular-definitions) id))) (value (hashq-ref (fluid-ref circular-definitions) id)))
(if value (if value
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 ;;; This means both the variable the promise will return and the
@ -67,7 +67,7 @@
(define (circular-define! token) (define (circular-define! token)
(if (not (eq? (car token) 'circular-def)) (if (not (eq? (car token) 'circular-def))
(error "invalid token for circular-define!" token)) (error "invalid token for circular-define!" token))
(let ((value #f) (let ((value #f)
(table (fluid-ref circular-definitions)) (table (fluid-ref circular-definitions))
(id (cdr token))) (id (cdr token)))
@ -85,25 +85,25 @@
(define (force-promises! data) (define (force-promises! data)
(cond (cond
((pair? data) ((pair? data)
(begin (begin
(if (promise? (car data)) (if (promise? (car data))
(set-car! data (force (car data))) (set-car! data (force (car data)))
(force-promises! (car data))) (force-promises! (car data)))
(if (promise? (cdr data)) (if (promise? (cdr data))
(set-cdr! data (force (cdr data))) (set-cdr! data (force (cdr data)))
(force-promises! (cdr data))))) (force-promises! (cdr data)))))
((vector? data) ((vector? data)
(let ((len (vector-length data))) (let ((len (vector-length data)))
(let iterate ((i 0)) (let iterate ((i 0))
(if (< i len) (if (< i len)
(let ((el (vector-ref data i))) (let ((el (vector-ref data i)))
(if (promise? el) (if (promise? el)
(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 ;;; We need peek-functionality for the next lexer token, this is done
;;; with some single token look-ahead storage. This is handled by a ;;; with some single token look-ahead storage. This is handled by a
@ -116,19 +116,19 @@
(let ((look-ahead #f)) (let ((look-ahead #f))
(lambda (action) (lambda (action)
(if (eq? action 'finish) (if (eq? action 'finish)
(if look-ahead (if look-ahead
(error "lexer-buffer is not empty when finished") (error "lexer-buffer is not empty when finished")
#f) #f)
(begin (begin
(if (not look-ahead) (if (not look-ahead)
(set! look-ahead (lex))) (set! look-ahead (lex)))
(case action (case action
((peek) look-ahead) ((peek) look-ahead)
((get) ((get)
(let ((result look-ahead)) (let ((result look-ahead))
(set! look-ahead #f) (set! look-ahead #f)
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 ;;; Get the contents of a list, where the opening parentheses has
;;; already been found. The same code is used for vectors and lists, ;;; already been found. The same code is used for vectors and lists,
@ -141,24 +141,25 @@
(let* ((next (lex 'peek)) (let* ((next (lex 'peek))
(type (car next))) (type (car next)))
(cond (cond
((eq? type (if close-square 'square-close 'paren-close)) ((eq? type (if close-square 'square-close 'paren-close))
(begin (begin
(if (not (eq? (car (lex 'get)) type)) (if (not (eq? (car (lex 'get)) type))
(error "got different token than peeked")) (error "got different token than peeked"))
'())) '()))
((and allow-dot (eq? type 'dot)) ((and allow-dot (eq? type 'dot))
(begin (begin
(if (not (eq? (car (lex 'get)) type)) (if (not (eq? (car (lex 'get)) type))
(error "got different token than peeked")) (error "got different token than peeked"))
(let ((tail (get-list lex #f close-square))) (let ((tail (get-list lex #f close-square)))
(if (not (= (length tail) 1)) (if (not (= (length tail) 1))
(parse-error next "expected exactly one element after dot")) (parse-error next
(car tail)))) "expected exactly one element after dot"))
(else (car tail))))
;; Do both parses in exactly this sequence! (else
(let* ((head (get-expression lex)) ;; Do both parses in exactly this sequence!
(tail (get-list lex allow-dot close-square))) (let* ((head (get-expression lex))
(cons head tail)))))) (tail (get-list lex allow-dot close-square)))
(cons head tail))))))
;;; Parse a single expression from a lexer-buffer. This is the main ;;; Parse a single expression from a lexer-buffer. This is the main
;;; routine in our recursive-descent parser. ;;; routine in our recursive-descent parser.
@ -173,13 +174,16 @@
(type (car token)) (type (car token))
(return (lambda (result) (return (lambda (result)
(if (pair? result) (if (pair? result)
(set-source-properties! result (source-properties token))) (set-source-properties!
result
(source-properties token)))
result))) result)))
(case type (case type
((integer float symbol character string) ((integer float symbol character string)
(return (cdr token))) (return (cdr token)))
((quote backquote unquote unquote-splicing) ((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) ((paren-open)
(return (get-list lex #t #f))) (return (get-list lex #t #f)))
((square-open) ((square-open)
@ -194,7 +198,7 @@
(force-promises! expr) (force-promises! expr)
expr)) expr))
(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 ;;; Define the reader function based on this; build a lexer, a
;;; lexer-buffer, and then parse a single expression to return. We also ;;; 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) (define-module (language elisp runtime)
#:export (void #:export (void
nil-value t-value nil-value
value-slot-module function-slot-module t-value
value-slot-module
function-slot-module
elisp-bool elisp-bool
ensure-fluid! reference-variable reference-variable-with-check ensure-fluid!
reference-variable
reference-variable-with-check
set-variable! set-variable!
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.
@ -61,8 +66,8 @@
(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. This is ;;; Routines for access to elisp dynamically bound symbols. This is
;;; used for runtime access using functions like symbol-value or set, ;;; used for runtime access using functions like symbol-value or set,
@ -74,10 +79,10 @@
(let ((intf (resolve-interface module)) (let ((intf (resolve-interface module))
(resolved (resolve-module module))) (resolved (resolve-module module)))
(if (not (module-defined? intf sym)) (if (not (module-defined? intf sym))
(let ((fluid (make-fluid))) (let ((fluid (make-fluid)))
(fluid-set! fluid void) (fluid-set! fluid void)
(module-define! resolved sym fluid) (module-define! resolved sym fluid)
(module-export! resolved `(,sym)))))) (module-export! resolved `(,sym))))))
(define (reference-variable module sym) (define (reference-variable module sym)
(ensure-fluid! module sym) (ensure-fluid! module sym)
@ -87,8 +92,8 @@
(define (reference-variable-with-check module sym) (define (reference-variable-with-check module sym)
(let ((value (reference-variable module sym))) (let ((value (reference-variable module sym)))
(if (eq? value void) (if (eq? value void)
(runtime-error "variable is void:" sym) (runtime-error "variable is void:" sym)
value))) value)))
(define (set-variable! module sym value) (define (set-variable! module sym value)
(ensure-fluid! module sym) (ensure-fluid! module sym)

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

@ -28,68 +28,85 @@
;;; Equivalence and equalness predicates. ;;; Equivalence and equalness predicates.
(built-in-func eq (lambda (a b) (built-in-func eq
(elisp-bool (eq? a b)))) (lambda (a b)
(elisp-bool (eq? a b))))
(built-in-func equal (lambda (a b) (built-in-func equal
(elisp-bool (equal? a b)))) (lambda (a b)
(elisp-bool (equal? a b))))
;;; Number predicates. ;;; Number predicates.
(built-in-func floatp (lambda (num) (built-in-func floatp
(elisp-bool (and (real? num) (lambda (num)
(or (inexact? num) (elisp-bool (and (real? num)
(prim not (integer? num))))))) (or (inexact? num)
(prim not (integer? num)))))))
(built-in-func integerp (lambda (num) (built-in-func integerp
(elisp-bool (and (exact? num) (lambda (num)
(integer? num))))) (elisp-bool (and (exact? num)
(integer? num)))))
(built-in-func numberp (lambda (num) (built-in-func numberp
(elisp-bool (real? num)))) (lambda (num)
(elisp-bool (real? num))))
(built-in-func wholenump (lambda (num) (built-in-func wholenump
(elisp-bool (and (exact? num) (lambda (num)
(integer? num) (elisp-bool (and (exact? num)
(prim >= num 0))))) (integer? num)
(prim >= num 0)))))
(built-in-func zerop (lambda (num) (built-in-func zerop
(elisp-bool (prim = num 0)))) (lambda (num)
(elisp-bool (prim = num 0))))
;;; Number comparisons. ;;; Number comparisons.
(built-in-func = (lambda (num1 num2) (built-in-func =
(elisp-bool (prim = num1 num2)))) (lambda (num1 num2)
(elisp-bool (prim = num1 num2))))
(built-in-func /= (lambda (num1 num2) (built-in-func /=
(elisp-bool (prim not (prim = num1 num2))))) (lambda (num1 num2)
(elisp-bool (prim not (prim = num1 num2)))))
(built-in-func < (lambda (num1 num2) (built-in-func <
(elisp-bool (prim < num1 num2)))) (lambda (num1 num2)
(elisp-bool (prim < num1 num2))))
(built-in-func <= (lambda (num1 num2) (built-in-func <=
(elisp-bool (prim <= num1 num2)))) (lambda (num1 num2)
(elisp-bool (prim <= num1 num2))))
(built-in-func > (lambda (num1 num2) (built-in-func >
(elisp-bool (prim > num1 num2)))) (lambda (num1 num2)
(elisp-bool (prim > num1 num2))))
(built-in-func >= (lambda (num1 num2) (built-in-func >=
(elisp-bool (prim >= num1 num2)))) (lambda (num1 num2)
(elisp-bool (prim >= num1 num2))))
(built-in-func max (lambda (. nums) (built-in-func max
(prim apply (@ (guile) max) nums))) (lambda (. nums)
(prim apply (@ (guile) max) nums)))
(built-in-func min (lambda (. nums) (built-in-func min
(prim apply (@ (guile) min) nums))) (lambda (. nums)
(prim apply (@ (guile) min) nums)))
(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
(if (exact? num) (lambda (num)
(exact->inexact num) (if (exact? num)
num))) (exact->inexact num)
num)))
;;; TODO: truncate, floor, ceiling, round. ;;; TODO: truncate, floor, ceiling, round.
@ -148,48 +165,48 @@
(built-in-func car (built-in-func car
(lambda (el) (lambda (el)
(if (null? el) (if (null? el)
nil-value nil-value
(prim car el)))) (prim car el))))
(built-in-func cdr (built-in-func cdr
(lambda (el) (lambda (el)
(if (null? el) (if (null? el)
nil-value nil-value
(prim cdr el)))) (prim cdr el))))
(built-in-func car-safe (built-in-func car-safe
(lambda (el) (lambda (el)
(if (pair? el) (if (pair? el)
(prim car el) (prim car el)
nil-value))) nil-value)))
(built-in-func cdr-safe (built-in-func cdr-safe
(lambda (el) (lambda (el)
(if (pair? el) (if (pair? el)
(prim cdr el) (prim cdr el)
nil-value))) nil-value)))
(built-in-func nth (built-in-func nth
(lambda (n lst) (lambda (n lst)
(if (negative? n) (if (negative? n)
(prim car lst) (prim car lst)
(let iterate ((i n) (let iterate ((i n)
(tail lst)) (tail lst))
(cond (cond
((null? tail) nil-value) ((null? tail) nil-value)
((zero? i) (prim car tail)) ((zero? i) (prim car tail))
(else (iterate (prim 1- i) (prim cdr tail)))))))) (else (iterate (prim 1- i) (prim cdr tail))))))))
(built-in-func nthcdr (built-in-func nthcdr
(lambda (n lst) (lambda (n lst)
(if (negative? n) (if (negative? n)
lst lst
(let iterate ((i n) (let iterate ((i n)
(tail lst)) (tail lst))
(cond (cond
((null? tail) nil-value) ((null? tail) nil-value)
((zero? i) tail) ((zero? i) tail)
(else (iterate (prim 1- i) (prim cdr tail)))))))) (else (iterate (prim 1- i) (prim cdr tail))))))))
(built-in-func length (@ (guile) length)) (built-in-func length (@ (guile) length))
@ -212,31 +229,36 @@
(built-in-func number-sequence (built-in-func number-sequence
(lambda (from . rest) (lambda (from . rest)
(if (prim > (prim length rest) 2) (if (prim > (prim length rest) 2)
(runtime-error "too many arguments for number-sequence" (runtime-error "too many arguments for number-sequence"
(prim cdddr rest)) (prim cdddr rest))
(if (null? rest) (if (null? rest)
`(,from) `(,from)
(let ((to (prim car rest)) (let ((to (prim car rest))
(sep (if (or (null? (prim cdr rest)) (sep (if (or (null? (prim cdr rest))
(eq? nil-value (prim cadr rest))) (eq? nil-value (prim cadr rest)))
1 1
(prim cadr rest)))) (prim cadr rest))))
(cond (cond
((or (eq? nil-value to) (prim = to from)) `(,from)) ((or (eq? nil-value to) (prim = to from)) `(,from))
((and (zero? sep) (prim not (prim = from to))) ((and (zero? sep) (prim not (prim = from to)))
(runtime-error "infinite list in number-sequence")) (runtime-error "infinite list in number-sequence"))
((prim < (prim * to sep) (prim * from sep)) '()) ((prim < (prim * to sep) (prim * from sep)) '())
(else (else
(let iterate ((i (prim + (let iterate ((i (prim +
from from
(prim * sep (prim *
(prim quotient sep
(prim abs (prim - to from)) (prim quotient
(prim abs sep))))) (prim abs
(result '())) (prim -
(if (prim = i from) to
(prim cons i result) from))
(iterate (prim - i sep) (prim cons i result))))))))))) (prim abs sep)))))
(result '()))
(if (prim = i from)
(prim cons i result)
(iterate (prim - i sep)
(prim cons i result)))))))))))
;;; Changing lists. ;;; Changing lists.
@ -281,12 +303,16 @@
(built-in-func boundp (built-in-func boundp
(lambda (sym) (lambda (sym)
(elisp-bool (prim not (elisp-bool (prim not
(eq? void (reference-variable value-slot-module sym)))))) (eq? void
(reference-variable value-slot-module
sym))))))
(built-in-func fboundp (built-in-func fboundp
(lambda (sym) (lambda (sym)
(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 ;;; Function calls. These must take care of special cases, like using
;;; symbols or raw lambda-lists as functions! ;;; symbols or raw lambda-lists as functions!
@ -294,15 +320,17 @@
(built-in-func apply (built-in-func apply
(lambda (func . args) (lambda (func . args)
(let ((real-func (cond (let ((real-func (cond
((symbol? func) ((symbol? func)
(reference-variable-with-check function-slot-module (reference-variable-with-check
func)) function-slot-module
((list? func) func))
(if (and (prim not (null? func)) ((list? func)
(eq? (prim car func) 'lambda)) (if (and (prim not (null? func))
(compile func #:from 'elisp #:to 'value) (eq? (prim car func) 'lambda))
(runtime-error "list is not a function" func))) (compile func #:from 'elisp #:to 'value)
(else func)))) (runtime-error "list is not a function"
func)))
(else func))))
(prim apply (@ (guile) apply) real-func args)))) (prim apply (@ (guile) apply) real-func args))))
(built-in-func funcall (built-in-func funcall

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

@ -61,23 +61,23 @@
(lambda (. clauses) (lambda (. clauses)
(let iterate ((tail clauses)) (let iterate ((tail clauses))
(if (null? tail) (if (null? tail)
'nil 'nil
(let ((cur (car tail)) (let ((cur (car tail))
(rest (iterate (cdr tail)))) (rest (iterate (cdr tail))))
(prim cond (prim cond
((prim or (not (list? cur)) (null? cur)) ((prim or (not (list? cur)) (null? cur))
(macro-error "invalid clause in cond" cur)) (macro-error "invalid clause in cond" cur))
((null? (cdr cur)) ((null? (cdr cur))
(let ((var (gensym))) (let ((var (gensym)))
`(without-void-checks (,var) `(without-void-checks (,var)
(lexical-let ((,var ,(car cur))) (lexical-let ((,var ,(car cur)))
(if ,var (if ,var
,var ,var
,rest))))) ,rest)))))
(else (else
`(if ,(car cur) `(if ,(car cur)
(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.
@ -103,54 +103,56 @@
x x
(let ((var (gensym))) (let ((var (gensym)))
`(without-void-checks `(without-void-checks
(,var) (,var)
(lexical-let ((,var ,x)) (lexical-let ((,var ,x))
(if ,var (if ,var
,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)
(if (prim or (not (list? args)) (if (prim or
(< (length args) 2) (not (list? args))
(> (length args) 3)) (< (length args) 2)
(macro-error "invalid dotimes arguments" args) (> (length args) 3))
(let ((var (car args)) (macro-error "invalid dotimes arguments" args)
(count (cadr args))) (let ((var (car args))
(if (not (symbol? var)) (count (cadr args)))
(macro-error "expected symbol as dotimes variable")) (if (not (symbol? var))
`(let ((,var 0)) (macro-error "expected symbol as dotimes variable"))
(while ((guile-primitive <) ,var ,count) `(let ((,var 0))
,@body (while ((guile-primitive <) ,var ,count)
(setq ,var ((guile-primitive 1+) ,var))) ,@body
,@(if (= (length args) 3) (setq ,var ((guile-primitive 1+) ,var)))
(list (caddr args)) ,@(if (= (length args) 3)
'())))))) (list (caddr args))
'()))))))
(built-in-macro dolist (built-in-macro dolist
(lambda (args . body) (lambda (args . body)
(if (prim or (not (list? args)) (if (prim or
(< (length args) 2) (not (list? args))
(> (length args) 3)) (< (length args) 2)
(macro-error "invalid dolist arguments" args) (> (length args) 3))
(let ((var (car args)) (macro-error "invalid dolist arguments" args)
(iter-list (cadr args)) (let ((var (car args))
(tailvar (gensym))) (iter-list (cadr args))
(if (not (symbol? var)) (tailvar (gensym)))
(macro-error "expected symbol as dolist variable") (if (not (symbol? var))
`(let (,var) (macro-error "expected symbol as dolist variable")
(without-void-checks (,tailvar) `(let (,var)
(lexical-let ((,tailvar ,iter-list)) (without-void-checks (,tailvar)
(while ((guile-primitive not) (lexical-let ((,tailvar ,iter-list))
((guile-primitive null?) ,tailvar)) (while ((guile-primitive not)
(setq ,var ((guile-primitive car) ,tailvar)) ((guile-primitive null?) ,tailvar))
,@body (setq ,var ((guile-primitive car) ,tailvar))
(setq ,tailvar ((guile-primitive cdr) ,tailvar))) ,@body
,@(if (= (length args) 3) (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
(list (caddr args)) ,@(if (= (length args) 3)
'()))))))))) (list (caddr args))
'())))))))))
;;; Exception handling. unwind-protect and catch are implemented as ;;; Exception handling. unwind-protect and catch are implemented as
;;; macros (throw is a built-in function). ;;; macros (throw is a built-in function).
@ -165,22 +167,23 @@
(built-in-macro catch (built-in-macro catch
(lambda (tag . body) (lambda (tag . body)
(if (null? body) (if (null? body)
(macro-error "catch with empty body")) (macro-error "catch with empty body"))
(let ((tagsym (gensym))) (let ((tagsym (gensym)))
`(lexical-let ((,tagsym ,tag)) `(lexical-let ((,tagsym ,tag))
((guile-primitive catch) ((guile-primitive catch)
#t #t
(lambda () ,@body) (lambda () ,@body)
,(let* ((dummy-key (gensym)) ,(let* ((dummy-key (gensym))
(elisp-key (gensym)) (elisp-key (gensym))
(value (gensym)) (value (gensym))
(arglist `(,dummy-key ,elisp-key ,value))) (arglist `(,dummy-key ,elisp-key ,value)))
`(with-always-lexical ,arglist `(with-always-lexical
(lambda ,arglist ,arglist
(if (eq ,elisp-key ,tagsym) (lambda ,arglist
(if (eq ,elisp-key ,tagsym)
,value ,value
((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.
@ -188,11 +191,11 @@
(built-in-macro unwind-protect (built-in-macro unwind-protect
(lambda (body . clean-ups) (lambda (body . clean-ups)
(if (null? clean-ups) (if (null? clean-ups)
(macro-error "unwind-protect without cleanup code")) (macro-error "unwind-protect without cleanup code"))
`((guile-primitive dynamic-wind) `((guile-primitive dynamic-wind)
(lambda () nil) (lambda () nil)
(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.

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

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