mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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

32
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,19 +54,23 @@
;;; 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)))
(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)
@ -87,7 +92,8 @@
;;; 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)
@ -100,14 +106,13 @@
(if (or (not (list? syms))
(not (and-map symbol? syms)))
(error "can't bind non-symbols" syms))
(let ((lex ((record-accessor bindings-type 'lexical-bindings) bindings)))
(let ((lex ((record-accessor bindings-type 'lexical-bindings)
bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
(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)))
@ -119,5 +124,6 @@
(define (with-dynamic-bindings bindings syms proc)
(with-symbol-bindings bindings
syms (map (lambda (el) #f) syms)
syms
(map (lambda (el) #f) syms)
proc))

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

@ -56,9 +56,11 @@
;;; 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.
@ -96,7 +98,8 @@
(apply error args))
(define (runtime-error loc msg . args)
(make-application loc (make-primitive-ref loc 'error)
(make-application loc
(make-primitive-ref loc 'error)
(cons (make-const loc msg) args)))
;;; Generate code to ensure a global symbol is there for further use of
@ -106,7 +109,8 @@
;;; this routine.
(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)
(make-const loc sym))))
@ -127,13 +131,17 @@
;;; setting/reverting their values with a dynamic-wind.
(define (let-dynamic loc syms module vals body)
(call-primitive loc 'with-fluids*
(make-application loc (make-primitive-ref loc 'list)
(call-primitive
loc
'with-fluids*
(make-application loc
(make-primitive-ref loc 'list)
(map (lambda (sym)
(make-module-ref loc module sym #t))
syms))
(make-application loc (make-primitive-ref loc 'list) vals)
(make-lambda loc '()
(make-lambda loc
'()
(make-lambda-case #f '() #f #f #f '() '() body #f))))
;;; Handle access to a variable (reference/setting) correctly depending
@ -151,12 +159,15 @@
;;; instead if the variable has a lexical binding.
(define (reference-variable loc sym module)
(access-variable loc sym module
(lambda (lexical)
(make-lexical-ref loc lexical lexical))
(access-variable
loc
sym
module
(lambda (lexical) (make-lexical-ref loc lexical lexical))
(lambda ()
(mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc 'fluid-ref
(call-primitive loc
'fluid-ref
(make-module-ref loc module sym #t)))))
;;; Reference a variable and error if the value is void.
@ -164,9 +175,15 @@
(define (reference-with-check loc sym module)
(if (want-void-check? sym module)
(let ((var (gensym)))
(make-let loc '(value) `(,var) `(,(reference-variable loc sym module))
(make-conditional loc
(call-primitive loc 'eq?
(make-let
loc
'(value)
`(,var)
`(,(reference-variable loc sym module))
(make-conditional
loc
(call-primitive loc
'eq?
(make-module-ref loc runtime 'void #t)
(make-lexical-ref loc 'value var))
(runtime-error loc "variable is void:" (make-const loc sym))
@ -178,12 +195,15 @@
;;; when the variable has a lexical binding.
(define (set-variable! loc sym module value)
(access-variable loc sym module
(lambda (lexical)
(make-lexical-set loc lexical lexical value))
(access-variable
loc
sym
module
(lambda (lexical) (make-lexical-set loc lexical lexical value))
(lambda ()
(mark-global-needed! (fluid-ref bindings-data) sym module)
(call-primitive loc 'fluid-set!
(call-primitive loc
'fluid-set!
(make-module-ref loc module sym #t)
value))))
@ -192,12 +212,15 @@
;;; . val2) ...).
(define (process-let-bindings loc bindings)
(map (lambda (b)
(map
(lambda (b)
(if (symbol? b)
(cons b 'nil)
(if (or (not (list? b))
(not (= (length b) 2)))
(report-error loc "expected symbol or list of 2 elements in let")
(report-error
loc
"expected symbol or list of 2 elements in let")
(if (not (symbol? (car b)))
(report-error loc "expected symbol in let")
(cons (car b) (cadr b))))))
@ -243,15 +266,15 @@
(define (generate-let loc module bindings body)
(let ((bind (process-let-bindings loc bindings)))
(call-with-values
(lambda ()
(split-let-bindings bind module))
(lambda () (split-let-bindings bind module))
(lambda (lexical dynamic)
(for-each (lambda (sym)
(mark-global-needed! (fluid-ref bindings-data) sym module))
(mark-global-needed! (fluid-ref bindings-data)
sym
module))
(map car dynamic))
(let ((make-values (lambda (for)
(map (lambda (el)
(compile-expr (cdr el)))
(map (lambda (el) (compile-expr (cdr el)))
for)))
(make-body (lambda ()
(make-sequence loc (map compile-expr body)))))
@ -261,16 +284,26 @@
(let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
(dynamic-syms (map (lambda (el) (gensym)) dynamic))
(all-syms (append lexical-syms dynamic-syms))
(vals (append (make-values lexical) (make-values dynamic))))
(make-let loc all-syms all-syms vals
(with-lexical-bindings (fluid-ref bindings-data)
(vals (append (make-values lexical)
(make-values dynamic))))
(make-let loc
all-syms
all-syms
vals
(with-lexical-bindings
(fluid-ref bindings-data)
(map car lexical) lexical-syms
(lambda ()
(if (null? dynamic)
(make-body)
(let-dynamic loc (map car dynamic) module
(map (lambda (sym)
(make-lexical-ref loc sym sym))
(let-dynamic loc
(map car dynamic)
module
(map
(lambda (sym)
(make-lexical-ref loc
sym
sym))
dynamic-syms)
(make-body)))))))))))))
@ -282,7 +315,9 @@
(begin
(for-each (lambda (sym)
(if (not (bind-lexically? sym module))
(mark-global-needed! (fluid-ref bindings-data) sym module)))
(mark-global-needed! (fluid-ref bindings-data)
sym
module)))
(map car bind))
(let iterate ((tail bind))
(if (null? tail)
@ -291,13 +326,19 @@
(value (compile-expr (cdar tail))))
(if (bind-lexically? sym module)
(let ((target (gensym)))
(make-let loc `(,target) `(,target) `(,value)
(with-lexical-bindings (fluid-ref bindings-data)
`(,sym) `(,target)
(lambda ()
(iterate (cdr tail))))))
(make-let loc
`(,target)
`(,target)
`(,value)
(with-lexical-bindings
(fluid-ref bindings-data)
`(,sym)
`(,target)
(lambda () (iterate (cdr tail))))))
(let-dynamic loc
`(,(caar tail)) module `(,value)
`(,(caar tail))
module
`(,value)
(iterate (cdr tail))))))))))
;;; Split the argument list of a lambda expression into required,
@ -325,8 +366,11 @@
(final-optional (reverse optional))
(final-lexical (reverse lexical))
(final-dynamic (reverse dynamic)))
(values final-required final-optional #f
final-lexical final-dynamic)))
(values final-required
final-optional
#f
final-lexical
final-dynamic)))
((and (eq? mode 'required)
(eq? (car tail) '&optional))
(iterate (cdr tail) 'optional required optional lexical dynamic))
@ -344,11 +388,16 @@
(final-dynamic (reverse (if rest-lexical
dynamic
(cons rest dynamic)))))
(values final-required final-optional rest
final-lexical final-dynamic))))
(values final-required
final-optional
rest
final-lexical
final-dynamic))))
(else
(if (not (symbol? (car tail)))
(report-error loc "expected symbol in argument list, got" (car tail))
(report-error loc
"expected symbol in argument list, got"
(car tail))
(let* ((arg (car tail))
(bind-lexical (bind-arg-lexical? arg))
(new-lexical (if bind-lexical
@ -365,7 +414,8 @@
required (cons arg optional)
new-lexical new-dynamic))
(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 does not allow optional arguments but only one rest argument,
@ -423,55 +473,83 @@
(optional-sym (map make-sym lex-optionals))
(optional-lex-pairs (map cons lex-optionals optional-sym))
(find-required-pairs (lambda (filter)
(lset-intersection (lambda (name-sym el)
(eq? (car name-sym)
el))
required-pairs filter)))
(lset-intersection
(lambda (name-sym el)
(eq? (car name-sym) el))
required-pairs
filter)))
(required-lex-pairs (find-required-pairs lexical))
(rest-pair (if rest-lexical `((,rest . ,rest-sym)) '()))
(all-lex-pairs (append required-lex-pairs optional-lex-pairs
(all-lex-pairs (append required-lex-pairs
optional-lex-pairs
rest-pair)))
(for-each (lambda (sym)
(mark-global-needed! (fluid-ref bindings-data)
sym value-slot))
sym
value-slot))
dynamic)
(with-dynamic-bindings (fluid-ref bindings-data) dynamic
(with-dynamic-bindings
(fluid-ref bindings-data)
dynamic
(lambda ()
(with-lexical-bindings (fluid-ref bindings-data)
(with-lexical-bindings
(fluid-ref bindings-data)
(map car all-lex-pairs)
(map cdr all-lex-pairs)
(lambda ()
(make-lambda loc '()
(make-lambda loc
'()
(make-lambda-case
#f required #f
#f
required
#f
(if have-real-rest rest-name #f)
#f '()
#f
'()
(if have-real-rest
(append required-sym (list rest-sym))
required-sym)
(let* ((init-req (map (lambda (name-sym)
(make-lexical-ref loc (car name-sym)
(let* ((init-req
(map (lambda (name-sym)
(make-lexical-ref
loc
(car name-sym)
(cdr name-sym)))
(find-required-pairs dynamic)))
(init-nils (map (lambda (sym) (nil-value loc))
(init-nils
(map (lambda (sym) (nil-value loc))
(if rest-dynamic
`(,@dyn-optionals ,rest-sym)
dyn-optionals)))
(init (append init-req init-nils))
(func-body (make-sequence loc
`(,(process-optionals loc optional
rest-name rest-sym)
,(process-rest loc rest
rest-name rest-sym)
(func-body
(make-sequence
loc
`(,(process-optionals loc
optional
rest-name
rest-sym)
,(process-rest loc
rest
rest-name
rest-sym)
,@(map compile-expr body))))
(dynlet (let-dynamic loc dynamic value-slot
init func-body))
(full-body (if (null? dynamic) func-body dynlet)))
(dynlet (let-dynamic loc
dynamic
value-slot
init
func-body))
(full-body (if (null? dynamic)
func-body
dynlet)))
(if (null? optional-sym)
full-body
(make-let loc
optional-sym optional-sym
(map (lambda (sym) (nil-value loc)) optional-sym)
optional-sym
optional-sym
(map (lambda (sym)
(nil-value loc))
optional-sym)
full-body)))
#f))))))))))
@ -482,33 +560,58 @@
(let iterate ((tail optional))
(if (null? tail)
(make-void loc)
(make-conditional loc
(call-primitive loc 'null? (make-lexical-ref loc rest-name rest-sym))
(make-conditional
loc
(call-primitive loc
'null?
(make-lexical-ref loc rest-name rest-sym))
(make-void loc)
(make-sequence loc
(list (set-variable! loc (car tail) value-slot
(call-primitive loc 'car
(make-lexical-ref loc rest-name rest-sym)))
(make-lexical-set loc rest-name rest-sym
(call-primitive loc 'cdr
(make-sequence
loc
(list (set-variable! loc
(car tail)
value-slot
(call-primitive loc
'car
(make-lexical-ref
loc
rest-name
rest-sym)))
(make-lexical-set
loc
rest-name
rest-sym
(call-primitive
loc
'cdr
(make-lexical-ref loc rest-name rest-sym)))
(iterate (cdr tail))))))))
;;; This builds the code to set the rest variable to nil if it is empty.
(define (process-rest loc rest rest-name rest-sym)
(let ((rest-empty (call-primitive loc 'null?
(make-lexical-ref loc rest-name rest-sym))))
(let ((rest-empty (call-primitive loc
'null?
(make-lexical-ref loc
rest-name
rest-sym))))
(cond
(rest
(make-conditional loc rest-empty
(make-conditional loc
rest-empty
(make-void loc)
(set-variable! loc rest value-slot
(make-lexical-ref loc rest-name rest-sym))))
(set-variable! loc
rest
value-slot
(make-lexical-ref loc
rest-name
rest-sym))))
((not (null? rest-sym))
(make-conditional loc rest-empty
(make-void loc)
(runtime-error loc "too many arguments and no rest argument")))
(runtime-error
loc
"too many arguments and no rest argument")))
(else (make-void loc)))))
;;; Handle the common part of defconst and defvar, that is, checking for
@ -570,19 +673,26 @@
(compile-expr (cadr expr))
(let* ((head (car expr))
(processed-tail (process-backquote loc (cdr expr)))
(head-is-list-2 (and (list? head) (= (length head) 2)))
(head-unquote (and head-is-list-2 (unquote? (car head))))
(head-is-list-2 (and (list? head)
(= (length head) 2)))
(head-unquote (and head-is-list-2
(unquote? (car head))))
(head-unquote-splicing (and head-is-list-2
(unquote-splicing? (car head)))))
(unquote-splicing?
(car head)))))
(if head-unquote-splicing
(call-primitive loc 'append
(compile-expr (cadr head)) processed-tail)
(call-primitive loc
'append
(compile-expr (cadr head))
processed-tail)
(call-primitive loc 'cons
(if head-unquote
(compile-expr (cadr head))
(process-backquote loc head))
processed-tail))))
(report-error loc "non-pair expression contains unquotes" expr))
(report-error loc
"non-pair expression contains unquotes"
expr))
(make-const loc expr)))
;;; Temporarily update a list of symbols that are handled specially
@ -623,17 +733,20 @@
(make-sequence loc (map compile-expr forms)))
((if ,condition ,ifclause)
(make-conditional loc (compile-expr condition)
(make-conditional loc
(compile-expr condition)
(compile-expr ifclause)
(nil-value loc)))
((if ,condition ,ifclause ,elseclause)
(make-conditional loc (compile-expr condition)
(make-conditional loc
(compile-expr condition)
(compile-expr ifclause)
(compile-expr elseclause)))
((if ,condition ,ifclause . ,elses)
(make-conditional loc (compile-expr condition)
(make-conditional loc
(compile-expr condition)
(compile-expr ifclause)
(make-sequence loc (map compile-expr elses))))
@ -644,20 +757,25 @@
((defconst ,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
(make-sequence loc
(list (set-variable! loc sym value-slot (compile-expr value))
(list (set-variable! loc
sym
value-slot
(compile-expr value))
(make-const loc sym)))))
((defvar ,sym) (make-const loc sym))
((defvar ,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
(make-sequence loc
(list (make-conditional loc
(call-primitive loc 'eq?
(make-sequence
loc
(list (make-conditional
loc
(call-primitive loc
'eq?
(make-module-ref loc runtime 'void #t)
(reference-variable loc sym value-slot))
(set-variable! loc sym value-slot
(compile-expr value))
(set-variable! loc sym value-slot (compile-expr value))
(make-void loc))
(make-const loc sym)))))
@ -666,22 +784,33 @@
;; large lists of symbol expression pairs are very unlikely.
((setq . ,args) (guard (not (null? args)))
(make-sequence loc
(make-sequence
loc
(let iterate ((tail args))
(let ((sym (car tail))
(tailtail (cdr tail)))
(if (not (symbol? sym))
(report-error loc "expected symbol in setq")
(if (null? tailtail)
(report-error loc "missing value for symbol in setq" sym)
(report-error loc
"missing value for symbol in setq"
sym)
(let* ((val (compile-expr (car tailtail)))
(op (set-variable! loc sym value-slot val)))
(if (null? (cdr tailtail))
(let* ((temp (gensym))
(ref (make-lexical-ref loc temp temp)))
(list (make-let loc `(,temp) `(,temp) `(,val)
(make-sequence loc
(list (set-variable! loc sym value-slot ref)
(list (make-let
loc
`(,temp)
`(,temp)
`(,val)
(make-sequence
loc
(list (set-variable! loc
sym
value-slot
ref)
ref)))))
(cons (set-variable! loc sym value-slot val)
(iterate (cdr tailtail)))))))))))
@ -759,7 +888,9 @@
(let* ((itersym (gensym))
(compiled-body (map compile-expr body))
(iter-call (make-application loc
(make-lexical-ref loc 'iterate itersym)
(make-lexical-ref loc
'iterate
itersym)
(list)))
(full-body (make-sequence loc
`(,@compiled-body ,iter-call)))
@ -767,10 +898,22 @@
(compile-expr condition)
full-body
(nil-value loc)))
(iter-thunk (make-lambda loc '()
(make-lambda-case #f '() #f #f #f '() '()
lambda-body #f))))
(make-letrec loc #f '(iterate) (list itersym) (list iter-thunk)
(iter-thunk (make-lambda loc
'()
(make-lambda-case #f
'()
#f
#f
#f
'()
'()
lambda-body
#f))))
(make-letrec loc
#f
'(iterate)
(list itersym)
(list iter-thunk)
iter-call)))
;; Either (lambda ...) or (function (lambda ...)) denotes a
@ -790,8 +933,12 @@
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
(make-sequence loc
(list (set-variable! loc name function-slot
(compile-lambda loc args body))
(list (set-variable! loc
name
function-slot
(compile-lambda loc
args
body))
(make-const loc name)))))
;; Define a macro (this is done directly at compile-time!). FIXME:
@ -866,12 +1013,18 @@
((#:disable-void-check)
(if (valid-symbol-list-arg? value)
(fluid-set! disable-void-check value)
(report-error #f "Invalid value for #:disable-void-check" value)))
(report-error #f
"Invalid value for #:disable-void-check"
value)))
((#:always-lexical)
(if (valid-symbol-list-arg? value)
(fluid-set! always-lexical value)
(report-error #f "Invalid value for #:always-lexical" value)))
(else (report-error #f "Invalid compiler option" key)))))))
(report-error #f
"Invalid value for #:always-lexical"
value)))
(else (report-error #f
"Invalid compiler option"
key)))))))
;;; Entry point for compilation to TreeIL. This creates the bindings
;;; data structure, and after compiling the main expression we need to
@ -887,7 +1040,8 @@
(let ((loc (location expr))
(compiled (compile-expr expr)))
(make-sequence loc
`(,@(map-globals-needed (fluid-ref bindings-data)
`(,@(map-globals-needed
(fluid-ref bindings-data)
(lambda (mod sym)
(generate-ensure-global loc sym mod)))
,compiled))))

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

@ -106,7 +106,10 @@
(begin
(unread-char cur port)
result)
(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)))))))
;;; Read a character and process escape-sequences when necessary. The
@ -116,13 +119,23 @@
;;; 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.
@ -160,8 +173,8 @@
((#\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!
;; 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
@ -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,7 +202,8 @@
(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)
@ -202,7 +217,8 @@
(need-no-escape? (lambda (c)
(or (char-numeric? c)
(char-alphabetic? c)
(char-set-contains? no-escape-punctuation
(char-set-contains?
no-escape-punctuation
c)))))
(cond
((eof-object? c) (finish))
@ -229,13 +245,17 @@
(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)
@ -289,7 +309,8 @@
(else
(unread-char escaped port)
(unread-char cur port)
(iterate (cons (integer->char (get-character port #t))
(iterate
(cons (integer->char (get-character port #t))
result-chars))))))
(else (iterate (cons cur result-chars)))))))
;; Circular markers (either reference or definition).
@ -316,16 +337,15 @@
(else
(unread-char c port)
(call-with-values
(lambda ()
(get-symbol-or-number port))
(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.
;; 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
@ -335,10 +355,11 @@
(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
;; 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))
@ -346,7 +367,9 @@
((float)
(return 'float (let ((num (string->number str)))
(if (exact? num)
(error "expected inexact float" str num))
(error "expected inexact float"
str
num))
num)))
(else (error "wrong number/symbol type" type)))))))))))
@ -354,8 +377,7 @@
;;; 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

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

@ -152,7 +152,8 @@
(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"))
(parse-error next
"expected exactly one element after dot"))
(car tail))))
(else
;; Do both parses in exactly this sequence!
@ -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)

13
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.

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

@ -28,65 +28,82 @@
;;; Equivalence and equalness predicates.
(built-in-func eq (lambda (a b)
(built-in-func eq
(lambda (a b)
(elisp-bool (eq? a b))))
(built-in-func equal (lambda (a b)
(built-in-func equal
(lambda (a b)
(elisp-bool (equal? a b))))
;;; Number predicates.
(built-in-func floatp (lambda (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)
(built-in-func integerp
(lambda (num)
(elisp-bool (and (exact? num)
(integer? num)))))
(built-in-func numberp (lambda (num)
(built-in-func numberp
(lambda (num)
(elisp-bool (real? num))))
(built-in-func wholenump (lambda (num)
(built-in-func wholenump
(lambda (num)
(elisp-bool (and (exact? num)
(integer? num)
(prim >= num 0)))))
(built-in-func zerop (lambda (num)
(built-in-func zerop
(lambda (num)
(elisp-bool (prim = num 0))))
;;; Number comparisons.
(built-in-func = (lambda (num1 num2)
(built-in-func =
(lambda (num1 num2)
(elisp-bool (prim = num1 num2))))
(built-in-func /= (lambda (num1 num2)
(built-in-func /=
(lambda (num1 num2)
(elisp-bool (prim not (prim = num1 num2)))))
(built-in-func < (lambda (num1 num2)
(built-in-func <
(lambda (num1 num2)
(elisp-bool (prim < num1 num2))))
(built-in-func <= (lambda (num1 num2)
(built-in-func <=
(lambda (num1 num2)
(elisp-bool (prim <= num1 num2))))
(built-in-func > (lambda (num1 num2)
(built-in-func >
(lambda (num1 num2)
(elisp-bool (prim > num1 num2))))
(built-in-func >= (lambda (num1 num2)
(built-in-func >=
(lambda (num1 num2)
(elisp-bool (prim >= num1 num2))))
(built-in-func max (lambda (. nums)
(built-in-func max
(lambda (. nums)
(prim apply (@ (guile) max) nums)))
(built-in-func min (lambda (. 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)
(built-in-func float
(lambda (num)
(if (exact? num)
(exact->inexact num)
num)))
@ -229,14 +246,19 @@
(else
(let iterate ((i (prim +
from
(prim * sep
(prim *
sep
(prim quotient
(prim abs (prim - to from))
(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)))))))))))
(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!
@ -295,13 +321,15 @@
(lambda (func . args)
(let ((real-func (cond
((symbol? func)
(reference-variable-with-check function-slot-module
(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)))
(runtime-error "list is not a function"
func)))
(else func))))
(prim apply (@ (guile) apply) real-func args))))

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

@ -113,7 +113,8 @@
(built-in-macro dotimes
(lambda (args . body)
(if (prim or (not (list? args))
(if (prim or
(not (list? args))
(< (length args) 2)
(> (length args) 3))
(macro-error "invalid dotimes arguments" args)
@ -131,7 +132,8 @@
(built-in-macro dolist
(lambda (args . body)
(if (prim or (not (list? args))
(if (prim or
(not (list? args))
(< (length args) 2)
(> (length args) 3))
(macro-error "invalid dolist arguments" args)
@ -175,7 +177,8 @@
(elisp-key (gensym))
(value (gensym))
(arglist `(,dummy-key ,elisp-key ,value)))
`(with-always-lexical ,arglist
`(with-always-lexical
,arglist
(lambda ,arglist
(if (eq ,elisp-key ,tagsym)
,value