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

32
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,19 +54,23 @@
;;; 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)
@ -87,7 +92,8 @@
;;; 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)
@ -100,14 +106,13 @@
(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)))
@ -119,5 +124,6 @@
(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))

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

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

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

@ -106,7 +106,10 @@
(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
"invalid digit in escape-code"
base
cur))
(iterate (+ (* result base) value) (1+ procdigs))))))) (iterate (+ (* result base) value) (1+ procdigs)))))))
;;; Read a character and process escape-sequences when necessary. The ;;; Read a character and process escape-sequences when necessary. The
@ -116,13 +119,23 @@
;;; 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.
@ -160,8 +173,8 @@
((#\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
@ -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,7 +202,8 @@
(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)
@ -202,7 +217,8 @@
(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?
no-escape-punctuation
c))))) c)))))
(cond (cond
((eof-object? c) (finish)) ((eof-object? c) (finish))
@ -229,13 +245,17 @@
(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)
@ -289,7 +309,8 @@
(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
(cons (integer->char (get-character port #t))
result-chars)))))) result-chars))))))
(else (iterate (cons cur result-chars))))))) (else (iterate (cons cur result-chars)))))))
;; Circular markers (either reference or definition). ;; Circular markers (either reference or definition).
@ -316,16 +337,15 @@
(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 ;; str could be empty if the first character is already
;; already something not allowed in a symbol (and not ;; something not allowed in a symbol (and not escaped)!
;; escaped)! Take care about that, it is an error ;; Take care about that, it is an error because that
;; because that character should have been handled ;; character should have been handled elsewhere or is
;; elsewhere or is invalid in the input. ;; 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
@ -335,10 +355,11 @@
(return 'symbol (string->symbol str)))) (return 'symbol (string->symbol str))))
((integer) ((integer)
;; In elisp, something like "1." is an integer, while ;; In elisp, something like "1." is an integer, while
;; string->number returns an inexact real. Thus we ;; string->number returns an inexact real. Thus we need
;; need a conversion here, but it should always ;; a conversion here, but it should always result in an
;; result in an integer! ;; integer!
(return 'integer (return
'integer
(let ((num (inexact->exact (string->number str)))) (let ((num (inexact->exact (string->number str))))
(if (not (integer? num)) (if (not (integer? num))
(error "expected integer" str num)) (error "expected integer" str num))
@ -346,7 +367,9 @@
((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"
str
num))
num))) num)))
(else (error "wrong number/symbol type" type))))))))))) (else (error "wrong number/symbol type" type)))))))))))
@ -354,8 +377,7 @@
;;; 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

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

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

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

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

@ -28,65 +28,82 @@
;;; Equivalence and equalness predicates. ;;; Equivalence and equalness predicates.
(built-in-func eq (lambda (a b) (built-in-func eq
(lambda (a b)
(elisp-bool (eq? a b)))) (elisp-bool (eq? a b))))
(built-in-func equal (lambda (a b) (built-in-func equal
(lambda (a b)
(elisp-bool (equal? a b)))) (elisp-bool (equal? a b))))
;;; Number predicates. ;;; Number predicates.
(built-in-func floatp (lambda (num) (built-in-func floatp
(lambda (num)
(elisp-bool (and (real? num) (elisp-bool (and (real? num)
(or (inexact? num) (or (inexact? num)
(prim not (integer? num))))))) (prim not (integer? num)))))))
(built-in-func integerp (lambda (num) (built-in-func integerp
(lambda (num)
(elisp-bool (and (exact? num) (elisp-bool (and (exact? num)
(integer? num))))) (integer? num)))))
(built-in-func numberp (lambda (num) (built-in-func numberp
(lambda (num)
(elisp-bool (real? num)))) (elisp-bool (real? num))))
(built-in-func wholenump (lambda (num) (built-in-func wholenump
(lambda (num)
(elisp-bool (and (exact? num) (elisp-bool (and (exact? num)
(integer? num) (integer? num)
(prim >= num 0))))) (prim >= num 0)))))
(built-in-func zerop (lambda (num) (built-in-func zerop
(lambda (num)
(elisp-bool (prim = num 0)))) (elisp-bool (prim = num 0))))
;;; Number comparisons. ;;; Number comparisons.
(built-in-func = (lambda (num1 num2) (built-in-func =
(lambda (num1 num2)
(elisp-bool (prim = num1 num2)))) (elisp-bool (prim = num1 num2))))
(built-in-func /= (lambda (num1 num2) (built-in-func /=
(lambda (num1 num2)
(elisp-bool (prim not (prim = 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)))) (elisp-bool (prim < num1 num2))))
(built-in-func <= (lambda (num1 num2) (built-in-func <=
(lambda (num1 num2)
(elisp-bool (prim <= num1 num2)))) (elisp-bool (prim <= num1 num2))))
(built-in-func > (lambda (num1 num2) (built-in-func >
(lambda (num1 num2)
(elisp-bool (prim > num1 num2)))) (elisp-bool (prim > num1 num2))))
(built-in-func >= (lambda (num1 num2) (built-in-func >=
(lambda (num1 num2)
(elisp-bool (prim >= num1 num2)))) (elisp-bool (prim >= num1 num2))))
(built-in-func max (lambda (. nums) (built-in-func max
(lambda (. nums)
(prim apply (@ (guile) max) nums))) (prim apply (@ (guile) max) nums)))
(built-in-func min (lambda (. nums) (built-in-func min
(lambda (. nums)
(prim apply (@ (guile) min) 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
(lambda (num)
(if (exact? num) (if (exact? num)
(exact->inexact num) (exact->inexact num)
num))) num)))
@ -229,14 +246,19 @@
(else (else
(let iterate ((i (prim + (let iterate ((i (prim +
from from
(prim * sep (prim *
sep
(prim quotient (prim quotient
(prim abs (prim - to from)) (prim abs
(prim -
to
from))
(prim abs sep))))) (prim abs sep)))))
(result '())) (result '()))
(if (prim = i from) (if (prim = i from)
(prim cons i result) (prim cons i result)
(iterate (prim - i sep) (prim cons i result))))))))))) (iterate (prim - i sep)
(prim cons i result)))))))))))
;;; Changing lists. ;;; Changing lists.
@ -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!
@ -295,13 +321,15 @@
(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
function-slot-module
func)) func))
((list? func) ((list? func)
(if (and (prim not (null? func)) (if (and (prim not (null? func))
(eq? (prim car func) 'lambda)) (eq? (prim car func) 'lambda))
(compile func #:from 'elisp #:to 'value) (compile func #:from 'elisp #:to 'value)
(runtime-error "list is not a function" func))) (runtime-error "list is not a function"
func)))
(else func)))) (else func))))
(prim apply (@ (guile) apply) real-func args)))) (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 (built-in-macro dotimes
(lambda (args . body) (lambda (args . body)
(if (prim or (not (list? args)) (if (prim or
(not (list? args))
(< (length args) 2) (< (length args) 2)
(> (length args) 3)) (> (length args) 3))
(macro-error "invalid dotimes arguments" args) (macro-error "invalid dotimes arguments" args)
@ -131,7 +132,8 @@
(built-in-macro dolist (built-in-macro dolist
(lambda (args . body) (lambda (args . body)
(if (prim or (not (list? args)) (if (prim or
(not (list? args))
(< (length args) 2) (< (length args) 2)
(> (length args) 3)) (> (length args) 3))
(macro-error "invalid dolist arguments" args) (macro-error "invalid dolist arguments" args)
@ -175,7 +177,8 @@
(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
,arglist
(lambda ,arglist (lambda ,arglist
(if (eq ,elisp-key ,tagsym) (if (eq ,elisp-key ,tagsym)
,value ,value