(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
;;; 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.
;;; slot-module.
(define (mark-global-needed! bindings sym module)
- (let* ((old-needed ((record-accessor bindings-type 'needed-globals) bindings))
+ (let* ((old-needed ((record-accessor bindings-type 'needed-globals)
+ bindings))
(old-in-module (or (assoc-ref old-needed module) '()))
(new-in-module (if (memq sym old-in-module)
- old-in-module
- (cons sym old-in-module)))
+ old-in-module
+ (cons sym old-in-module)))
(new-needed (assoc-set! old-needed module new-in-module)))
- ((record-modifier bindings-type 'needed-globals) bindings new-needed)))
+ ((record-modifier bindings-type 'needed-globals)
+ bindings
+ new-needed)))
;;; Cycle through all globals needed in order to generate the code for
;;; their creation or some other analysis.
(define (map-globals-needed bindings proc)
- (let ((needed ((record-accessor bindings-type 'needed-globals) bindings)))
+ (let ((needed ((record-accessor bindings-type 'needed-globals)
+ bindings)))
(let iterate-modules ((mod-tail needed)
(mod-result '()))
(if (null? mod-tail)
- mod-result
- (iterate-modules
- (cdr mod-tail)
- (let* ((aentry (car mod-tail))
- (module (car aentry))
- (symbols (cdr aentry)))
- (let iterate-symbols ((sym-tail symbols)
- (sym-result mod-result))
- (if (null? sym-tail)
- sym-result
- (iterate-symbols (cdr sym-tail)
- (cons (proc module (car sym-tail))
- sym-result))))))))))
+ mod-result
+ (iterate-modules
+ (cdr mod-tail)
+ (let* ((aentry (car mod-tail))
+ (module (car aentry))
+ (symbols (cdr aentry)))
+ (let iterate-symbols ((sym-tail symbols)
+ (sym-result mod-result))
+ (if (null? sym-tail)
+ sym-result
+ (iterate-symbols (cdr sym-tail)
+ (cons (proc module (car sym-tail))
+ sym-result))))))))))
;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound.
(define (get-lexical-binding bindings sym)
- (let* ((lex ((record-accessor bindings-type 'lexical-bindings) bindings))
+ (let* ((lex ((record-accessor bindings-type 'lexical-bindings)
+ bindings))
(slot (hash-ref lex sym #f)))
(if slot
- (fluid-ref slot)
- #f)))
+ (fluid-ref slot)
+ #f)))
;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.
(define (with-symbol-bindings bindings syms targets proc)
(if (or (not (list? syms))
(not (and-map symbol? syms)))
- (error "can't bind non-symbols" syms))
- (let ((lex ((record-accessor bindings-type 'lexical-bindings) bindings)))
+ (error "can't bind non-symbols" syms))
+ (let ((lex ((record-accessor bindings-type 'lexical-bindings)
+ bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
- (hash-set! lex sym (make-fluid))))
+ (hash-set! lex sym (make-fluid))))
syms)
- (with-fluids* (map (lambda (sym)
- (hash-ref lex sym))
- syms)
+ (with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
targets
proc)))
(define (with-lexical-bindings bindings syms targets proc)
(if (or (not (list? targets))
(not (and-map symbol? targets)))
- (error "invalid targets for lexical binding" targets)
- (with-symbol-bindings bindings syms targets proc)))
+ (error "invalid targets for lexical binding" targets)
+ (with-symbol-bindings bindings syms targets proc)))
(define (with-dynamic-bindings bindings syms proc)
(with-symbol-bindings bindings
- syms (map (lambda (el) #f) syms)
+ syms
+ (map (lambda (el) #f) syms)
proc))
;;; 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.
(apply error args))
(define (runtime-error loc msg . args)
- (make-application loc (make-primitive-ref loc 'error)
- (cons (make-const loc msg) args)))
+ (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
;;; a given symbol. In general during the compilation, those needed are
;;; this routine.
(define (generate-ensure-global loc sym module)
- (make-application loc (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
+ (make-application loc
+ (make-module-ref loc runtime 'ensure-fluid! #t)
+ (list (make-const loc module)
+ (make-const loc sym))))
;;; See if we should do a void-check for a given variable. That means,
;;; check that this check is not disabled via the compiler options for
;;; 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)
- (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-case #f '() #f #f #f '() '() body #f))))
+ (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-case #f '() #f #f #f '() '() body #f))))
;;; Handle access to a variable (reference/setting) correctly depending
;;; on whether it is currently lexically or dynamically bound. lexical
(define (access-variable loc sym module handle-lexical handle-dynamic)
(let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
(if (and lexical (equal? module value-slot))
- (handle-lexical lexical)
- (handle-dynamic))))
+ (handle-lexical lexical)
+ (handle-dynamic))))
;;; Generate code to reference a variable. For references in the
;;; value-slot module, we may want to generate a lexical reference
;;; 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))
- (lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc 'fluid-ref
- (make-module-ref loc module sym #t)))))
+ (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
+ (make-module-ref loc module sym #t)))))
;;; Reference a variable and error if the value is void.
(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?
+ (let ((var (gensym)))
+ (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))
(make-lexical-ref loc 'value var))))
- (reference-variable loc sym module)))
+ (reference-variable loc sym module)))
;;; Generate code to set a variable. Just as with reference-variable, in
;;; case of a reference to value-slot, we want to generate a lexical set
;;; 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))
- (lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc 'fluid-set!
- (make-module-ref loc module sym #t)
- 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!
+ (make-module-ref loc module sym #t)
+ value))))
;;; Process the bindings part of a let or let* expression; that is,
;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
;;; . val2) ...).
(define (process-let-bindings loc bindings)
- (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")
+ (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")
(if (not (symbol? (car b)))
- (report-error loc "expected symbol in let")
- (cons (car b) (cadr b))))))
- bindings))
+ (report-error loc "expected symbol in let")
+ (cons (car b) (cadr b))))))
+ bindings))
;;; Split the let bindings into a list to be done lexically and one
;;; dynamically. A symbol will be bound lexically if and only if: We're
(lexical '())
(dynamic '()))
(if (null? tail)
- (values (reverse lexical) (reverse dynamic))
- (if (bind-lexically? (caar tail) module)
- (iterate (cdr tail) (cons (car tail) lexical) dynamic)
- (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
+ (values (reverse lexical) (reverse dynamic))
+ (if (bind-lexically? (caar tail) module)
+ (iterate (cdr tail) (cons (car tail) lexical) dynamic)
+ (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
;;; Compile let and let* expressions. The code here is used both for
;;; let/let* and flet/flet*, just with a different bindings module.
(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)))))
(if (null? lexical)
- (let-dynamic loc (map car dynamic) module
- (make-values dynamic) (make-body))
- (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)
- (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))
- dynamic-syms)
- (make-body)))))))))))))
+ (let-dynamic loc (map car dynamic) module
+ (make-values dynamic) (make-body))
+ (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)
+ (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))
+ dynamic-syms)
+ (make-body)))))))))))))
;;; Let* is compiled to a cascaded set of "small lets" for each binding
;;; in turn so that each one already sees the preceding bindings.
(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)
- (make-sequence loc (map compile-expr body))
- (let ((sym (caar tail))
- (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))))))
- (let-dynamic loc
- `(,(caar tail)) module `(,value)
- (iterate (cdr tail))))))))))
+ (make-sequence loc (map compile-expr body))
+ (let ((sym (caar tail))
+ (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))))))
+ (let-dynamic loc
+ `(,(caar tail))
+ module
+ `(,value)
+ (iterate (cdr tail))))))))))
;;; Split the argument list of a lambda expression into required,
;;; optional and rest arguments and also check it is actually valid.
(lexical '())
(dynamic '()))
(cond
- ((null? tail)
- (let ((final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse lexical))
- (final-dynamic (reverse 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))
- ((eq? (car tail) '&rest)
- (if (or (null? (cdr tail))
- (not (null? (cddr tail))))
- (report-error loc "expected exactly one symbol after &rest")
- (let* ((rest (cadr tail))
- (rest-lexical (bind-arg-lexical? rest))
- (final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse (if rest-lexical
- (cons rest lexical)
- lexical)))
- (final-dynamic (reverse (if rest-lexical
- dynamic
- (cons rest 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))
+ ((null? tail)
+ (let ((final-required (reverse required))
+ (final-optional (reverse optional))
+ (final-lexical (reverse lexical))
+ (final-dynamic (reverse 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))
+ ((eq? (car tail) '&rest)
+ (if (or (null? (cdr tail))
+ (not (null? (cddr tail))))
+ (report-error loc "expected exactly one symbol after &rest")
+ (let* ((rest (cadr tail))
+ (rest-lexical (bind-arg-lexical? rest))
+ (final-required (reverse required))
+ (final-optional (reverse optional))
+ (final-lexical (reverse (if rest-lexical
+ (cons rest lexical)
+ lexical)))
+ (final-dynamic (reverse (if rest-lexical
+ dynamic
+ (cons rest 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))
(let* ((arg (car tail))
(bind-lexical (bind-arg-lexical? arg))
(new-lexical (if bind-lexical
- (cons arg lexical)
- lexical))
+ (cons arg lexical)
+ lexical))
(new-dynamic (if bind-lexical
- dynamic
- (cons arg dynamic))))
+ dynamic
+ (cons arg dynamic))))
(case mode
((required) (iterate (cdr tail) mode
(cons arg required) optional
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,
(define (compile-lambda loc args body)
(if (not (list? args))
- (report-error loc "expected list for argument-list" args))
+ (report-error loc "expected list for argument-list" args))
(if (null? body)
- (report-error loc "function body might not be empty"))
+ (report-error loc "function body might not be empty"))
(call-with-values
- (lambda ()
- (split-lambda-arguments loc args))
+ (lambda ()
+ (split-lambda-arguments loc args))
(lambda (required optional rest lexical dynamic)
(let* ((make-sym (lambda (sym) (gensym)))
(required-sym (map make-sym required))
(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
- (lambda ()
- (with-lexical-bindings (fluid-ref bindings-data)
- (map car all-lex-pairs)
- (map cdr all-lex-pairs)
- (lambda ()
- (make-lambda loc '()
- (make-lambda-case
- #f required #f
- (if have-real-rest rest-name #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)
- (cdr name-sym)))
- (find-required-pairs dynamic)))
- (init-nils (map (lambda (sym) (nil-value loc))
+ (with-dynamic-bindings
+ (fluid-ref bindings-data)
+ dynamic
+ (lambda ()
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ (map car all-lex-pairs)
+ (map cdr all-lex-pairs)
+ (lambda ()
+ (make-lambda loc
+ '()
+ (make-lambda-case
+ #f
+ required
+ #f
+ (if have-real-rest rest-name #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)
+ (cdr name-sym)))
+ (find-required-pairs dynamic)))
+ (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)
- ,@(map compile-expr body))))
- (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)
- full-body)))
- #f))))))))))
+ `(,@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)
+ ,@(map compile-expr body))))
+ (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)
+ full-body)))
+ #f))))))))))
;;; Build the code to handle setting of optional arguments that are
;;; present and updating the rest list.
(define (process-optionals loc optional rest-name rest-sym)
(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-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-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-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-void loc)
- (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")))
- (else (make-void loc)))))
+ (rest
+ (make-conditional loc
+ rest-empty
+ (make-void loc)
+ (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")))
+ (else (make-void loc)))))
;;; Handle the common part of defconst and defvar, that is, checking for
;;; a correct doc string and arguments as well as maybe in the future
(define (handle-var-def loc sym doc)
(cond
- ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
- ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
- ((and (not (null? doc)) (not (string? (car doc))))
- (report-error loc "expected string as third argument of defvar, got"
- (car doc)))
- ;; TODO: Handle doc string if present.
- (else #t)))
+ ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
+ ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
+ ((and (not (null? doc)) (not (string? (car doc))))
+ (report-error loc "expected string as third argument of defvar, got"
+ (car doc)))
+ ;; TODO: Handle doc string if present.
+ (else #t)))
;;; Handle macro bindings.
(define (define-macro! loc sym definition)
(let ((resolved (resolve-module macro-slot)))
(if (is-macro? sym)
- (report-error loc "macro is already defined" sym)
- (begin
- (module-define! resolved sym definition)
- (module-export! resolved (list sym))))))
+ (report-error loc "macro is already defined" sym)
+ (begin
+ (module-define! resolved sym definition)
+ (module-export! resolved (list sym))))))
(define (get-macro sym)
(module-ref (resolve-module macro-slot) sym))
(define (contains-unquotes? expr)
(if (pair? expr)
- (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
- #t
- (or (contains-unquotes? (car expr))
- (contains-unquotes? (cdr expr))))
- #f))
+ (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
+ #t
+ (or (contains-unquotes? (car expr))
+ (contains-unquotes? (cdr expr))))
+ #f))
;;; Process a backquoted expression by building up the needed
;;; cons/append calls. For splicing, it is assumed that the expression
(define (process-backquote loc expr)
(if (contains-unquotes? expr)
- (if (pair? expr)
- (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
- (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-unquote-splicing (and head-is-list-2
- (unquote-splicing? (car head)))))
- (if head-unquote-splicing
- (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))
- (make-const loc expr)))
+ (if (pair? expr)
+ (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
+ (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-unquote-splicing (and head-is-list-2
+ (unquote-splicing?
+ (car head)))))
+ (if head-unquote-splicing
+ (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))
+ (make-const loc expr)))
;;; Temporarily update a list of symbols that are handled specially
;;; (disabled void check or always lexical) for compiling body. We need
(define (with-added-symbols loc fluid syms body)
(if (null? body)
- (report-error loc "symbol-list construct has empty body"))
+ (report-error loc "symbol-list construct has empty body"))
(if (not (or (eq? syms 'all)
(and (list? syms) (and-map symbol? syms))))
- (report-error loc "invalid symbol list" syms))
+ (report-error loc "invalid symbol list" syms))
(let ((old (fluid-ref fluid))
(make-body (lambda ()
(make-sequence loc (map compile-expr body)))))
(if (eq? old 'all)
- (make-body)
- (let ((new (if (eq? syms 'all)
- 'all
- (append syms old))))
- (with-fluids ((fluid new))
- (make-body))))))
+ (make-body)
+ (let ((new (if (eq? syms 'all)
+ 'all
+ (append syms old))))
+ (with-fluids ((fluid new))
+ (make-body))))))
;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil.
(make-sequence loc (map compile-expr forms)))
((if ,condition ,ifclause)
- (make-conditional loc (compile-expr condition)
- (compile-expr ifclause)
- (nil-value loc)))
+ (make-conditional loc
+ (compile-expr condition)
+ (compile-expr ifclause)
+ (nil-value loc)))
((if ,condition ,ifclause ,elseclause)
- (make-conditional loc (compile-expr condition)
- (compile-expr ifclause)
- (compile-expr elseclause)))
+ (make-conditional loc
+ (compile-expr condition)
+ (compile-expr ifclause)
+ (compile-expr elseclause)))
((if ,condition ,ifclause . ,elses)
- (make-conditional loc (compile-expr condition)
- (compile-expr ifclause)
- (make-sequence loc (map compile-expr elses))))
+ (make-conditional loc
+ (compile-expr condition)
+ (compile-expr ifclause)
+ (make-sequence loc (map compile-expr elses))))
;; defconst and defvar are kept here in the compiler (rather than
;; doing them as macros) for if we may want to handle the docstring
((defconst ,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence loc
- (list (set-variable! loc sym value-slot (compile-expr value))
- (make-const loc sym)))))
+ (make-sequence loc
+ (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)))))
+ (make-const loc sym)))))
;; Build a set form for possibly multiple values. The code is not
;; formulated tail recursive because it is clearer this way and
;; large lists of symbol expression pairs are very unlikely.
((setq . ,args) (guard (not (null? args)))
- (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)
- (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)
- ref)))))
- (cons (set-variable! loc sym value-slot val)
- (iterate (cdr tailtail)))))))))))
+ (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)
+ (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)
+ ref)))))
+ (cons (set-variable! loc sym value-slot val)
+ (iterate (cdr tailtail)))))))))))
;; All lets (let, flet, lexical-let and let* forms) are done using
;; the generate-let/generate-let* methods.
(let* ((itersym (gensym))
(compiled-body (map compile-expr body))
(iter-call (make-application loc
- (make-lexical-ref loc 'iterate itersym)
- (list)))
+ (make-lexical-ref loc
+ 'iterate
+ itersym)
+ (list)))
(full-body (make-sequence loc
- `(,@compiled-body ,iter-call)))
+ `(,@compiled-body ,iter-call)))
(lambda-body (make-conditional loc
- (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-call)))
+ (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-call)))
;; Either (lambda ...) or (function (lambda ...)) denotes a
;; lambda-expression that should be compiled.
((defun ,name ,args . ,body)
(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))
- (make-const loc 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))
+ (make-const loc name)))))
;; Define a macro (this is done directly at compile-time!). FIXME:
;; Recursive macros don't work!
((defmacro ,name ,args . ,body)
(if (not (symbol? name))
- (report-error loc "expected symbol as macro name" name)
- (let* ((tree-il (with-fluids ((bindings-data (make-bindings)))
- (compile-lambda loc args body)))
- (object (compile tree-il #:from 'tree-il #:to 'value)))
- (define-macro! loc name object)
- (make-const loc name))))
+ (report-error loc "expected symbol as macro name" name)
+ (let* ((tree-il (with-fluids ((bindings-data (make-bindings)))
+ (compile-lambda loc args body)))
+ (object (compile tree-il #:from 'tree-il #:to 'value)))
+ (define-macro! loc name object)
+ (make-const loc name))))
;; XXX: Maybe we could implement backquotes in macros, too.
((,func . ,args)
(make-application loc
- (if (symbol? func)
- (reference-with-check loc func function-slot)
- (compile-expr func))
- (map compile-expr args)))
+ (if (symbol? func)
+ (reference-with-check loc func function-slot)
+ (compile-expr func))
+ (map compile-expr args)))
(else
- (report-error loc "unrecognized elisp" expr))))
+ (report-error loc "unrecognized elisp" expr))))
;;; Compile a single expression to TreeIL.
(define (compile-expr expr)
(let ((loc (location expr)))
(cond
- ((symbol? expr)
- (compile-symbol loc expr))
- ((pair? expr)
- (compile-pair loc expr))
- (else (make-const loc expr)))))
+ ((symbol? expr)
+ (compile-symbol loc expr))
+ ((pair? expr)
+ (compile-pair loc expr))
+ (else (make-const loc expr)))))
;;; Process the compiler options.
;;; FIXME: Why is '(()) passed as options by the REPL?
(define (process-options! opt)
(if (and (not (null? opt))
(not (equal? opt '(()))))
- (if (null? (cdr opt))
- (report-error #f "Invalid compiler options" opt)
- (let ((key (car opt))
- (value (cadr opt)))
- (case key
- ((#: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)))
- ((#: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)))))))
+ (if (null? (cdr opt))
+ (report-error #f "Invalid compiler options" opt)
+ (let ((key (car opt))
+ (value (cadr opt)))
+ (case key
+ ((#: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)))
+ ((#: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)))))))
;;; Entry point for compilation to TreeIL. This creates the bindings
;;; data structure, and after compiling the main expression we need to
(define (compile-tree-il expr env opts)
(values
- (with-fluids ((bindings-data (make-bindings))
- (disable-void-check '())
- (always-lexical '()))
- (process-options! opts)
- (let ((loc (location expr))
- (compiled (compile-expr expr)))
- (make-sequence loc
- `(,@(map-globals-needed (fluid-ref bindings-data)
- (lambda (mod sym)
- (generate-ensure-global loc sym mod)))
- ,compiled))))
- env
- env))
+ (with-fluids ((bindings-data (make-bindings))
+ (disable-void-check '())
+ (always-lexical '()))
+ (process-options! opts)
+ (let ((loc (location expr))
+ (compiled (compile-expr expr)))
+ (make-sequence loc
+ `(,@(map-globals-needed
+ (fluid-ref bindings-data)
+ (lambda (mod sym)
+ (generate-ensure-global loc sym mod)))
+ ,compiled))))
+ env
+ env))
(define (real-character chr)
(if (< chr 256)
- (integer->char chr)
- #\nul))
+ (integer->char chr)
+ #\nul))
;;; Return the control modified version of a character. This is not
;;; just setting a modifier bit, because ASCII conrol characters must be
(define (add-control chr)
(let ((real (real-character chr)))
(if (char-alphabetic? real)
- (- (char->integer (char-upcase real)) (char->integer #\@))
- (case real
- ((#\?) 127)
- ((#\@) 0)
- (else (set-char-bit chr 26))))))
+ (- (char->integer (char-upcase real)) (char->integer #\@))
+ (case real
+ ((#\?) 127)
+ ((#\@) 0)
+ (else (set-char-bit chr 26))))))
;;; Parse a charcode given in some base, basically octal or hexadecimal
;;; are needed. A requested number of digits can be given (#f means it
(let iterate ((result 0)
(procdigs 0))
(if (and digits (>= procdigs digits))
- result
- (let* ((cur (read-char port))
- (value (cond
- ((char-numeric? cur)
- (- (char->integer cur) (char->integer #\0)))
- ((char-alphabetic? cur)
- (let ((code (- (char->integer (char-upcase cur))
- (char->integer #\A))))
- (if (< code 0)
- #f
- (+ code 10))))
- (else #f)))
- (valid (and value (< value base))))
- (if (not valid)
- (if (or (not digits) early-return)
- (begin
- (unread-char cur port)
- result)
- (lexer-error port "invalid digit in escape-code" base cur))
- (iterate (+ (* result base) value) (1+ procdigs)))))))
+ result
+ (let* ((cur (read-char port))
+ (value (cond
+ ((char-numeric? cur)
+ (- (char->integer cur) (char->integer #\0)))
+ ((char-alphabetic? cur)
+ (let ((code (- (char->integer (char-upcase cur))
+ (char->integer #\A))))
+ (if (< code 0)
+ #f
+ (+ code 10))))
+ (else #f)))
+ (valid (and value (< value base))))
+ (if (not valid)
+ (if (or (not digits) early-return)
+ (begin
+ (unread-char cur port)
+ result)
+ (lexer-error port
+ "invalid digit in escape-code"
+ base
+ cur))
+ (iterate (+ (* result base) value) (1+ procdigs)))))))
;;; Read a character and process escape-sequences when necessary. The
;;; special in-string argument defines if this character is part of a
;;; characters.
(define basic-escape-codes
- '((#\a . 7) (#\b . 8) (#\t . 9)
- (#\n . 10) (#\v . 11) (#\f . 12) (#\r . 13)
- (#\e . 27) (#\s . 32) (#\d . 127)))
+ '((#\a . 7)
+ (#\b . 8)
+ (#\t . 9)
+ (#\n . 10)
+ (#\v . 11)
+ (#\f . 12)
+ (#\r . 13)
+ (#\e . 27)
+ (#\s . 32)
+ (#\d . 127)))
(define (get-character port in-string)
- (let ((meta-bits `((#\A . 22) (#\s . 23) (#\H . 24)
- (#\S . 25) (#\M . ,(if in-string 7 27))))
+ (let ((meta-bits `((#\A . 22)
+ (#\s . 23)
+ (#\H . 24)
+ (#\S . 25)
+ (#\M . ,(if in-string 7 27))))
(cur (read-char port)))
(if (char=? cur #\\)
- ;; Handle an escape-sequence.
- (let* ((escaped (read-char port))
- (esc-code (assq-ref basic-escape-codes escaped))
- (meta (assq-ref meta-bits escaped)))
- (cond
- ;; Meta-check must be before esc-code check because \s- must
- ;; be recognized as the super-meta modifier if a - follows.
- ;; If not, it will be caught as \s -> space escape code.
- ((and meta (is-char? (peek-char port) #\-))
- (if (not (char=? (read-char port) #\-))
- (error "expected - after control sequence"))
- (set-char-bit (get-character port in-string) meta))
- ;; One of the basic control character escape names?
- (esc-code esc-code)
- ;; Handle \ddd octal code if it is one.
- ((and (char>=? escaped #\0) (char<? escaped #\8))
- (begin
- (unread-char escaped port)
- (charcode-escape port 8 3 #t)))
- ;; Check for some escape-codes directly or otherwise use the
- ;; escaped character literally.
- (else
+ ;; Handle an escape-sequence.
+ (let* ((escaped (read-char port))
+ (esc-code (assq-ref basic-escape-codes escaped))
+ (meta (assq-ref meta-bits escaped)))
+ (cond
+ ;; Meta-check must be before esc-code check because \s- must
+ ;; be recognized as the super-meta modifier if a - follows.
+ ;; If not, it will be caught as \s -> space escape code.
+ ((and meta (is-char? (peek-char port) #\-))
+ (if (not (char=? (read-char port) #\-))
+ (error "expected - after control sequence"))
+ (set-char-bit (get-character port in-string) meta))
+ ;; One of the basic control character escape names?
+ (esc-code esc-code)
+ ;; Handle \ddd octal code if it is one.
+ ((and (char>=? escaped #\0) (char<? escaped #\8))
+ (begin
+ (unread-char escaped port)
+ (charcode-escape port 8 3 #t)))
+ ;; Check for some escape-codes directly or otherwise use the
+ ;; escaped character literally.
+ (else
(case escaped
((#\^) (add-control (get-character port in-string)))
((#\C)
(if (is-char? (peek-char port) #\-)
- (begin
- (if (not (char=? (read-char port) #\-))
- (error "expected - after control sequence"))
- (add-control (get-character port in-string)))
- escaped))
+ (begin
+ (if (not (char=? (read-char port) #\-))
+ (error "expected - after control sequence"))
+ (add-control (get-character port in-string)))
+ escaped))
((#\x) (charcode-escape port 16 #f #t))
((#\u) (charcode-escape port 16 4 #f))
((#\U) (charcode-escape port 16 8 #f))
(else (char->integer escaped))))))
- ;; No escape-sequence, just the literal character.
- ;; But remember to get the code instead!
- (char->integer cur))))
+ ;; No escape-sequence, just the literal character. But remember
+ ;; to get the code instead!
+ (char->integer cur))))
;;; Read a symbol or number from a port until something follows that
;;; marks the start of a new token (like whitespace or parentheses).
(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.
(had-escape #f))
(let* ((c (read-char port))
(finish (lambda ()
- (let ((result (list->string (reverse result-chars))))
+ (let ((result (list->string
+ (reverse result-chars))))
(values
- (cond
- ((and (not had-escape)
- (regexp-exec integer-regex result))
- 'integer)
- ((and (not had-escape)
- (regexp-exec float-regex result))
- 'float)
- (else 'symbol))
- result))))
+ (cond
+ ((and (not had-escape)
+ (regexp-exec integer-regex result))
+ 'integer)
+ ((and (not had-escape)
+ (regexp-exec float-regex result))
+ 'float)
+ (else 'symbol))
+ result))))
(need-no-escape? (lambda (c)
(or (char-numeric? c)
(char-alphabetic? c)
- (char-set-contains? no-escape-punctuation
- c)))))
+ (char-set-contains?
+ no-escape-punctuation
+ c)))))
(cond
- ((eof-object? c) (finish))
- ((need-no-escape? c) (iterate (cons c result-chars) had-escape))
- ((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
- (else
- (unread-char c port)
- (finish))))))
+ ((eof-object? c) (finish))
+ ((need-no-escape? c) (iterate (cons c result-chars) had-escape))
+ ((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
+ (else
+ (unread-char c port)
+ (finish))))))
;;; Parse a circular structure marker without the leading # (which was
;;; already read and recognized), that is, a number as identifier and
(define (get-circular-marker port)
(call-with-values
- (lambda ()
- (let iterate ((result 0))
- (let ((cur (read-char port)))
- (if (char-numeric? cur)
- (let ((val (- (char->integer cur) (char->integer #\0))))
- (iterate (+ (* result 10) val)))
- (values result cur)))))
+ (lambda ()
+ (let iterate ((result 0))
+ (let ((cur (read-char port)))
+ (if (char-numeric? cur)
+ (let ((val (- (char->integer cur) (char->integer #\0))))
+ (iterate (+ (* result 10) val)))
+ (values result cur)))))
(lambda (id type)
(case type
((#\#) `(circular-ref . ,id))
((#\=) `(circular-def . ,id))
- (else (lexer-error port "invalid circular marker character" type))))))
+ (else (lexer-error port
+ "invalid circular marker character"
+ type))))))
;;; Main lexer routine, which is given a port and does look for the next
;;; token.
(define (lex port)
- (let ((return (let ((file (if (file-port? port) (port-filename port) #f))
+ (let ((return (let ((file (if (file-port? port)
+ (port-filename port)
+ #f))
(line (1+ (port-line port)))
(column (1+ (port-column port))))
(lambda (token value)
;; and actually point to the very character to be read.
(c (read-char port)))
(cond
- ;; End of input must be specially marked to the parser.
- ((eof-object? c) '*eoi*)
- ;; Whitespace, just skip it.
- ((char-whitespace? c) (lex port))
- ;; The dot is only the one for dotted lists if followed by
- ;; whitespace. Otherwise it is considered part of a number of
- ;; symbol.
- ((and (char=? c #\.)
- (char-whitespace? (peek-char port)))
- (return 'dot #f))
- ;; Continue checking for literal character values.
- (else
- (case c
- ;; A line comment, skip until end-of-line is found.
- ((#\;)
- (let iterate ()
- (let ((cur (read-char port)))
- (if (or (eof-object? cur) (char=? cur #\newline))
+ ;; End of input must be specially marked to the parser.
+ ((eof-object? c) '*eoi*)
+ ;; Whitespace, just skip it.
+ ((char-whitespace? c) (lex port))
+ ;; The dot is only the one for dotted lists if followed by
+ ;; whitespace. Otherwise it is considered part of a number of
+ ;; symbol.
+ ((and (char=? c #\.)
+ (char-whitespace? (peek-char port)))
+ (return 'dot #f))
+ ;; Continue checking for literal character values.
+ (else
+ (case c
+ ;; A line comment, skip until end-of-line is found.
+ ((#\;)
+ (let iterate ()
+ (let ((cur (read-char port)))
+ (if (or (eof-object? cur) (char=? cur #\newline))
(lex port)
(iterate)))))
- ;; A character literal.
- ((#\?)
- (return 'character (get-character port #f)))
- ;; A literal string. This is mainly a sequence of characters
- ;; just as in the character literals, the only difference is
- ;; that escaped newline and space are to be completely ignored
- ;; and that meta-escapes set bit 7 rather than bit 27.
- ((#\")
- (let iterate ((result-chars '()))
- (let ((cur (read-char port)))
- (case cur
- ((#\")
- (return 'string (list->string (reverse result-chars))))
- ((#\\)
- (let ((escaped (read-char port)))
- (case escaped
- ((#\newline #\space)
- (iterate result-chars))
- (else
- (unread-char escaped port)
- (unread-char cur port)
- (iterate (cons (integer->char (get-character port #t))
- result-chars))))))
- (else (iterate (cons cur result-chars)))))))
- ;; Circular markers (either reference or definition).
- ((#\#)
- (let ((mark (get-circular-marker port)))
- (return (car mark) (cdr mark))))
- ;; Parentheses and other special-meaning single characters.
- ((#\() (return 'paren-open #f))
- ((#\)) (return 'paren-close #f))
- ((#\[) (return 'square-open #f))
- ((#\]) (return 'square-close #f))
- ((#\') (return 'quote #f))
- ((#\`) (return 'backquote #f))
- ;; Unquote and unquote-splicing.
- ((#\,)
- (if (is-char? (peek-char port) #\@)
+ ;; A character literal.
+ ((#\?)
+ (return 'character (get-character port #f)))
+ ;; A literal string. This is mainly a sequence of characters
+ ;; just as in the character literals, the only difference is
+ ;; that escaped newline and space are to be completely ignored
+ ;; and that meta-escapes set bit 7 rather than bit 27.
+ ((#\")
+ (let iterate ((result-chars '()))
+ (let ((cur (read-char port)))
+ (case cur
+ ((#\")
+ (return 'string (list->string (reverse result-chars))))
+ ((#\\)
+ (let ((escaped (read-char port)))
+ (case escaped
+ ((#\newline #\space)
+ (iterate result-chars))
+ (else
+ (unread-char escaped port)
+ (unread-char cur port)
+ (iterate
+ (cons (integer->char (get-character port #t))
+ result-chars))))))
+ (else (iterate (cons cur result-chars)))))))
+ ;; Circular markers (either reference or definition).
+ ((#\#)
+ (let ((mark (get-circular-marker port)))
+ (return (car mark) (cdr mark))))
+ ;; Parentheses and other special-meaning single characters.
+ ((#\() (return 'paren-open #f))
+ ((#\)) (return 'paren-close #f))
+ ((#\[) (return 'square-open #f))
+ ((#\]) (return 'square-close #f))
+ ((#\') (return 'quote #f))
+ ((#\`) (return 'backquote #f))
+ ;; Unquote and unquote-splicing.
+ ((#\,)
+ (if (is-char? (peek-char port) #\@)
(if (not (char=? (read-char port) #\@))
- (error "expected @ in unquote-splicing")
- (return 'unquote-splicing #f))
+ (error "expected @ in unquote-splicing")
+ (return 'unquote-splicing #f))
(return 'unquote #f)))
- ;; Remaining are numbers and symbols. Process input until next
- ;; whitespace is found, and see if it looks like a number
- ;; (float/integer) or symbol and return accordingly.
- (else
- (unread-char c port)
- (call-with-values
- (lambda ()
- (get-symbol-or-number port))
- (lambda (type str)
- (case type
- ((symbol)
- ;; str could be empty if the first character is
- ;; already something not allowed in a symbol (and not
- ;; escaped)! Take care about that, it is an error
- ;; because that character should have been handled
- ;; elsewhere or is invalid in the input.
- (if (zero? (string-length str))
- (begin
- ;; Take it out so the REPL might not get into an
- ;; infinite loop with further reading attempts.
- (read-char port)
- (error "invalid character in input" c))
- (return 'symbol (string->symbol str))))
- ((integer)
- ;; In elisp, something like "1." is an integer, while
- ;; string->number returns an inexact real. Thus we
- ;; need a conversion here, but it should always
- ;; result in an integer!
- (return 'integer
- (let ((num (inexact->exact (string->number str))))
- (if (not (integer? num))
- (error "expected integer" str num))
- num)))
- ((float)
- (return 'float (let ((num (string->number str)))
- (if (exact? num)
- (error "expected inexact float" str num))
- num)))
- (else (error "wrong number/symbol type" type)))))))))))
+ ;; Remaining are numbers and symbols. Process input until next
+ ;; whitespace is found, and see if it looks like a number
+ ;; (float/integer) or symbol and return accordingly.
+ (else
+ (unread-char c port)
+ (call-with-values
+ (lambda () (get-symbol-or-number port))
+ (lambda (type str)
+ (case type
+ ((symbol)
+ ;; str could be empty if the first character is already
+ ;; something not allowed in a symbol (and not escaped)!
+ ;; Take care about that, it is an error because that
+ ;; character should have been handled elsewhere or is
+ ;; invalid in the input.
+ (if (zero? (string-length str))
+ (begin
+ ;; Take it out so the REPL might not get into an
+ ;; infinite loop with further reading attempts.
+ (read-char port)
+ (error "invalid character in input" c))
+ (return 'symbol (string->symbol str))))
+ ((integer)
+ ;; In elisp, something like "1." is an integer, while
+ ;; string->number returns an inexact real. Thus we need
+ ;; a conversion here, but it should always result in an
+ ;; integer!
+ (return
+ 'integer
+ (let ((num (inexact->exact (string->number str))))
+ (if (not (integer? num))
+ (error "expected integer" str num))
+ num)))
+ ((float)
+ (return 'float (let ((num (string->number str)))
+ (if (exact? num)
+ (error "expected inexact float"
+ str
+ num))
+ num)))
+ (else (error "wrong number/symbol type" type)))))))))))
;;; Build a lexer thunk for a port. This is the exported routine which
;;; can be used to create a lexer for the parser to use.
(define (get-lexer port)
- (lambda ()
- (lex port)))
+ (lambda () (lex port)))
;;; Build a special lexer that will only read enough for one expression
;;; and then always return end-of-input. If we find one of the quotation
(paren-level 0))
(lambda ()
(if finished
- '*eoi*
- (let ((next (lex))
- (quotation #f))
- (case (car next)
- ((paren-open square-open)
- (set! paren-level (1+ paren-level)))
- ((paren-close square-close)
- (set! paren-level (1- paren-level)))
- ((quote backquote unquote unquote-splicing circular-def)
- (set! quotation #t)))
- (if (and (not quotation) (<= paren-level 0))
- (set! finished #t))
- next)))))
+ '*eoi*
+ (let ((next (lex))
+ (quotation #f))
+ (case (car next)
+ ((paren-open square-open)
+ (set! paren-level (1+ paren-level)))
+ ((paren-close square-close)
+ (set! paren-level (1- paren-level)))
+ ((quote backquote unquote unquote-splicing circular-def)
+ (set! quotation #t)))
+ (if (and (not quotation) (<= paren-level 0))
+ (set! finished #t))
+ next)))))
(define (circular-ref token)
(if (not (eq? (car token) 'circular-ref))
- (error "invalid token for circular-ref" token))
+ (error "invalid token for circular-ref" token))
(let* ((id (cdr token))
(value (hashq-ref (fluid-ref circular-definitions) id)))
(if value
- value
- (parse-error token "undefined circular reference" id))))
+ value
+ (parse-error token "undefined circular reference" id))))
;;; Returned is a closure that, when invoked, will set the final value.
;;; This means both the variable the promise will return and the
(define (circular-define! token)
(if (not (eq? (car token) 'circular-def))
- (error "invalid token for circular-define!" token))
+ (error "invalid token for circular-define!" token))
(let ((value #f)
(table (fluid-ref circular-definitions))
(id (cdr token)))
(define (force-promises! data)
(cond
- ((pair? data)
- (begin
- (if (promise? (car data))
- (set-car! data (force (car data)))
- (force-promises! (car data)))
- (if (promise? (cdr data))
- (set-cdr! data (force (cdr data)))
- (force-promises! (cdr data)))))
- ((vector? data)
- (let ((len (vector-length data)))
- (let iterate ((i 0))
- (if (< i len)
- (let ((el (vector-ref data i)))
- (if (promise? el)
- (vector-set! data i (force el))
- (force-promises! el))
- (iterate (1+ i)))))))
- ;; Else nothing needs to be done.
- ))
+ ((pair? data)
+ (begin
+ (if (promise? (car data))
+ (set-car! data (force (car data)))
+ (force-promises! (car data)))
+ (if (promise? (cdr data))
+ (set-cdr! data (force (cdr data)))
+ (force-promises! (cdr data)))))
+ ((vector? data)
+ (let ((len (vector-length data)))
+ (let iterate ((i 0))
+ (if (< i len)
+ (let ((el (vector-ref data i)))
+ (if (promise? el)
+ (vector-set! data i (force el))
+ (force-promises! el))
+ (iterate (1+ i)))))))
+ ;; Else nothing needs to be done.
+ ))
;;; We need peek-functionality for the next lexer token, this is done
;;; with some single token look-ahead storage. This is handled by a
(let ((look-ahead #f))
(lambda (action)
(if (eq? action 'finish)
- (if look-ahead
- (error "lexer-buffer is not empty when finished")
- #f)
- (begin
- (if (not look-ahead)
- (set! look-ahead (lex)))
- (case action
- ((peek) look-ahead)
- ((get)
- (let ((result look-ahead))
- (set! look-ahead #f)
- result))
- (else (error "invalid lexer-buffer action" action))))))))
+ (if look-ahead
+ (error "lexer-buffer is not empty when finished")
+ #f)
+ (begin
+ (if (not look-ahead)
+ (set! look-ahead (lex)))
+ (case action
+ ((peek) look-ahead)
+ ((get)
+ (let ((result look-ahead))
+ (set! look-ahead #f)
+ result))
+ (else (error "invalid lexer-buffer action" action))))))))
;;; Get the contents of a list, where the opening parentheses has
;;; already been found. The same code is used for vectors and lists,
(let* ((next (lex 'peek))
(type (car next)))
(cond
- ((eq? type (if close-square 'square-close 'paren-close))
- (begin
- (if (not (eq? (car (lex 'get)) type))
- (error "got different token than peeked"))
- '()))
- ((and allow-dot (eq? type 'dot))
- (begin
- (if (not (eq? (car (lex 'get)) type))
- (error "got different token than peeked"))
- (let ((tail (get-list lex #f close-square)))
- (if (not (= (length tail) 1))
- (parse-error next "expected exactly one element after dot"))
- (car tail))))
- (else
- ;; Do both parses in exactly this sequence!
- (let* ((head (get-expression lex))
- (tail (get-list lex allow-dot close-square)))
- (cons head tail))))))
+ ((eq? type (if close-square 'square-close 'paren-close))
+ (begin
+ (if (not (eq? (car (lex 'get)) type))
+ (error "got different token than peeked"))
+ '()))
+ ((and allow-dot (eq? type 'dot))
+ (begin
+ (if (not (eq? (car (lex 'get)) type))
+ (error "got different token than peeked"))
+ (let ((tail (get-list lex #f close-square)))
+ (if (not (= (length tail) 1))
+ (parse-error next
+ "expected exactly one element after dot"))
+ (car tail))))
+ (else
+ ;; Do both parses in exactly this sequence!
+ (let* ((head (get-expression lex))
+ (tail (get-list lex allow-dot close-square)))
+ (cons head tail))))))
;;; Parse a single expression from a lexer-buffer. This is the main
;;; routine in our recursive-descent parser.
(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)
(force-promises! expr)
expr))
(else
- (parse-error token "expected expression, got" token)))))
+ (parse-error token "expected expression, got" token)))))
;;; Define the reader function based on this; build a lexer, a
;;; lexer-buffer, and then parse a single expression to return. We also
(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.
(define (elisp-bool b)
(if b
- t-value
- nil-value))
+ t-value
+ nil-value))
;;; Routines for access to elisp dynamically bound symbols. This is
;;; used for runtime access using functions like symbol-value or set,
(let ((intf (resolve-interface module))
(resolved (resolve-module module)))
(if (not (module-defined? intf sym))
- (let ((fluid (make-fluid)))
- (fluid-set! fluid void)
- (module-define! resolved sym fluid)
- (module-export! resolved `(,sym))))))
+ (let ((fluid (make-fluid)))
+ (fluid-set! fluid void)
+ (module-define! resolved sym fluid)
+ (module-export! resolved `(,sym))))))
(define (reference-variable module sym)
(ensure-fluid! module sym)
(define (reference-variable-with-check module sym)
(let ((value (reference-variable module sym)))
(if (eq? value void)
- (runtime-error "variable is void:" sym)
- value)))
+ (runtime-error "variable is void:" sym)
+ value)))
(define (set-variable! module sym value)
(ensure-fluid! module sym)
;;; Equivalence and equalness predicates.
-(built-in-func eq (lambda (a b)
- (elisp-bool (eq? a b))))
+(built-in-func eq
+ (lambda (a b)
+ (elisp-bool (eq? a b))))
-(built-in-func equal (lambda (a b)
- (elisp-bool (equal? a b))))
+(built-in-func equal
+ (lambda (a b)
+ (elisp-bool (equal? a b))))
;;; Number predicates.
-(built-in-func floatp (lambda (num)
- (elisp-bool (and (real? num)
- (or (inexact? num)
- (prim not (integer? num)))))))
+(built-in-func floatp
+ (lambda (num)
+ (elisp-bool (and (real? num)
+ (or (inexact? num)
+ (prim not (integer? num)))))))
-(built-in-func integerp (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)))))
+(built-in-func integerp
+ (lambda (num)
+ (elisp-bool (and (exact? num)
+ (integer? num)))))
-(built-in-func numberp (lambda (num)
- (elisp-bool (real? num))))
+(built-in-func numberp
+ (lambda (num)
+ (elisp-bool (real? num))))
-(built-in-func wholenump (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)
- (prim >= num 0)))))
+(built-in-func wholenump
+ (lambda (num)
+ (elisp-bool (and (exact? num)
+ (integer? num)
+ (prim >= num 0)))))
-(built-in-func zerop (lambda (num)
- (elisp-bool (prim = num 0))))
+(built-in-func zerop
+ (lambda (num)
+ (elisp-bool (prim = num 0))))
;;; Number comparisons.
-(built-in-func = (lambda (num1 num2)
- (elisp-bool (prim = num1 num2))))
+(built-in-func =
+ (lambda (num1 num2)
+ (elisp-bool (prim = num1 num2))))
-(built-in-func /= (lambda (num1 num2)
- (elisp-bool (prim not (prim = num1 num2)))))
+(built-in-func /=
+ (lambda (num1 num2)
+ (elisp-bool (prim not (prim = num1 num2)))))
-(built-in-func < (lambda (num1 num2)
- (elisp-bool (prim < num1 num2))))
+(built-in-func <
+ (lambda (num1 num2)
+ (elisp-bool (prim < num1 num2))))
-(built-in-func <= (lambda (num1 num2)
- (elisp-bool (prim <= num1 num2))))
+(built-in-func <=
+ (lambda (num1 num2)
+ (elisp-bool (prim <= num1 num2))))
-(built-in-func > (lambda (num1 num2)
- (elisp-bool (prim > num1 num2))))
+(built-in-func >
+ (lambda (num1 num2)
+ (elisp-bool (prim > num1 num2))))
-(built-in-func >= (lambda (num1 num2)
- (elisp-bool (prim >= num1 num2))))
+(built-in-func >=
+ (lambda (num1 num2)
+ (elisp-bool (prim >= num1 num2))))
-(built-in-func max (lambda (. nums)
- (prim apply (@ (guile) max) nums)))
+(built-in-func max
+ (lambda (. nums)
+ (prim apply (@ (guile) max) nums)))
-(built-in-func min (lambda (. nums)
- (prim apply (@ (guile) min) nums)))
+(built-in-func min
+ (lambda (. nums)
+ (prim apply (@ (guile) min) nums)))
-(built-in-func abs (@ (guile) abs))
+(built-in-func abs
+ (@ (guile) abs))
;;; Number conversion.
-(built-in-func float (lambda (num)
- (if (exact? num)
- (exact->inexact num)
- num)))
+(built-in-func float
+ (lambda (num)
+ (if (exact? num)
+ (exact->inexact num)
+ num)))
;;; TODO: truncate, floor, ceiling, round.
(built-in-func car
(lambda (el)
(if (null? el)
- nil-value
- (prim car el))))
+ nil-value
+ (prim car el))))
(built-in-func cdr
(lambda (el)
(if (null? el)
- nil-value
- (prim cdr el))))
+ nil-value
+ (prim cdr el))))
(built-in-func car-safe
(lambda (el)
(if (pair? el)
- (prim car el)
- nil-value)))
+ (prim car el)
+ nil-value)))
(built-in-func cdr-safe
(lambda (el)
(if (pair? el)
- (prim cdr el)
- nil-value)))
+ (prim cdr el)
+ nil-value)))
(built-in-func nth
(lambda (n lst)
(if (negative? n)
- (prim car lst)
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) (prim car tail))
- (else (iterate (prim 1- i) (prim cdr tail))))))))
+ (prim car lst)
+ (let iterate ((i n)
+ (tail lst))
+ (cond
+ ((null? tail) nil-value)
+ ((zero? i) (prim car tail))
+ (else (iterate (prim 1- i) (prim cdr tail))))))))
(built-in-func nthcdr
(lambda (n lst)
(if (negative? n)
- lst
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) tail)
- (else (iterate (prim 1- i) (prim cdr tail))))))))
+ lst
+ (let iterate ((i n)
+ (tail lst))
+ (cond
+ ((null? tail) nil-value)
+ ((zero? i) tail)
+ (else (iterate (prim 1- i) (prim cdr tail))))))))
(built-in-func length (@ (guile) length))
(built-in-func number-sequence
(lambda (from . rest)
(if (prim > (prim length rest) 2)
- (runtime-error "too many arguments for number-sequence"
- (prim cdddr rest))
- (if (null? rest)
- `(,from)
- (let ((to (prim car rest))
- (sep (if (or (null? (prim cdr rest))
- (eq? nil-value (prim cadr rest)))
- 1
- (prim cadr rest))))
- (cond
- ((or (eq? nil-value to) (prim = to from)) `(,from))
- ((and (zero? sep) (prim not (prim = from to)))
- (runtime-error "infinite list in number-sequence"))
- ((prim < (prim * to sep) (prim * from sep)) '())
- (else
- (let iterate ((i (prim +
- from
- (prim * sep
- (prim quotient
- (prim abs (prim - to from))
- (prim abs sep)))))
- (result '()))
- (if (prim = i from)
- (prim cons i result)
- (iterate (prim - i sep) (prim cons i result)))))))))))
+ (runtime-error "too many arguments for number-sequence"
+ (prim cdddr rest))
+ (if (null? rest)
+ `(,from)
+ (let ((to (prim car rest))
+ (sep (if (or (null? (prim cdr rest))
+ (eq? nil-value (prim cadr rest)))
+ 1
+ (prim cadr rest))))
+ (cond
+ ((or (eq? nil-value to) (prim = to from)) `(,from))
+ ((and (zero? sep) (prim not (prim = from to)))
+ (runtime-error "infinite list in number-sequence"))
+ ((prim < (prim * to sep) (prim * from sep)) '())
+ (else
+ (let iterate ((i (prim +
+ from
+ (prim *
+ sep
+ (prim quotient
+ (prim abs
+ (prim -
+ to
+ from))
+ (prim abs sep)))))
+ (result '()))
+ (if (prim = i from)
+ (prim cons i result)
+ (iterate (prim - i sep)
+ (prim cons i result)))))))))))
;;; Changing lists.
(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!
(built-in-func apply
(lambda (func . args)
(let ((real-func (cond
- ((symbol? func)
- (reference-variable-with-check function-slot-module
- func))
- ((list? func)
- (if (and (prim not (null? func))
- (eq? (prim car func) 'lambda))
- (compile func #:from 'elisp #:to 'value)
- (runtime-error "list is not a function" func)))
- (else func))))
+ ((symbol? func)
+ (reference-variable-with-check
+ function-slot-module
+ func))
+ ((list? func)
+ (if (and (prim not (null? func))
+ (eq? (prim car func) 'lambda))
+ (compile func #:from 'elisp #:to 'value)
+ (runtime-error "list is not a function"
+ func)))
+ (else func))))
(prim apply (@ (guile) apply) real-func args))))
(built-in-func funcall
(lambda (. clauses)
(let iterate ((tail clauses))
(if (null? tail)
- 'nil
- (let ((cur (car tail))
- (rest (iterate (cdr tail))))
- (prim cond
- ((prim or (not (list? cur)) (null? cur))
- (macro-error "invalid clause in cond" cur))
- ((null? (cdr cur))
- (let ((var (gensym)))
- `(without-void-checks (,var)
- (lexical-let ((,var ,(car cur)))
- (if ,var
- ,var
- ,rest)))))
- (else
- `(if ,(car cur)
- (progn ,@(cdr cur))
- ,rest))))))))
+ 'nil
+ (let ((cur (car tail))
+ (rest (iterate (cdr tail))))
+ (prim cond
+ ((prim or (not (list? cur)) (null? cur))
+ (macro-error "invalid clause in cond" cur))
+ ((null? (cdr cur))
+ (let ((var (gensym)))
+ `(without-void-checks (,var)
+ (lexical-let ((,var ,(car cur)))
+ (if ,var
+ ,var
+ ,rest)))))
+ (else
+ `(if ,(car cur)
+ (progn ,@(cdr cur))
+ ,rest))))))))
;;; The and and or forms can also be easily defined with macros.
x
(let ((var (gensym)))
`(without-void-checks
- (,var)
- (lexical-let ((,var ,x))
- (if ,var
- ,var
- ,(iterate (car tail) (cdr tail)))))))))))
+ (,var)
+ (lexical-let ((,var ,x))
+ (if ,var
+ ,var
+ ,(iterate (car tail) (cdr tail)))))))))))
;;; Define the dotimes and dolist iteration macros.
(built-in-macro dotimes
(lambda (args . body)
- (if (prim or (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dotimes arguments" args)
- (let ((var (car args))
- (count (cadr args)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dotimes variable"))
- `(let ((,var 0))
- (while ((guile-primitive <) ,var ,count)
- ,@body
- (setq ,var ((guile-primitive 1+) ,var)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '()))))))
+ (if (prim or
+ (not (list? args))
+ (< (length args) 2)
+ (> (length args) 3))
+ (macro-error "invalid dotimes arguments" args)
+ (let ((var (car args))
+ (count (cadr args)))
+ (if (not (symbol? var))
+ (macro-error "expected symbol as dotimes variable"))
+ `(let ((,var 0))
+ (while ((guile-primitive <) ,var ,count)
+ ,@body
+ (setq ,var ((guile-primitive 1+) ,var)))
+ ,@(if (= (length args) 3)
+ (list (caddr args))
+ '()))))))
(built-in-macro dolist
(lambda (args . body)
- (if (prim or (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dolist arguments" args)
- (let ((var (car args))
- (iter-list (cadr args))
- (tailvar (gensym)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dolist variable")
- `(let (,var)
- (without-void-checks (,tailvar)
- (lexical-let ((,tailvar ,iter-list))
- (while ((guile-primitive not)
- ((guile-primitive null?) ,tailvar))
- (setq ,var ((guile-primitive car) ,tailvar))
- ,@body
- (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '())))))))))
+ (if (prim or
+ (not (list? args))
+ (< (length args) 2)
+ (> (length args) 3))
+ (macro-error "invalid dolist arguments" args)
+ (let ((var (car args))
+ (iter-list (cadr args))
+ (tailvar (gensym)))
+ (if (not (symbol? var))
+ (macro-error "expected symbol as dolist variable")
+ `(let (,var)
+ (without-void-checks (,tailvar)
+ (lexical-let ((,tailvar ,iter-list))
+ (while ((guile-primitive not)
+ ((guile-primitive null?) ,tailvar))
+ (setq ,var ((guile-primitive car) ,tailvar))
+ ,@body
+ (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
+ ,@(if (= (length args) 3)
+ (list (caddr args))
+ '())))))))))
;;; Exception handling. unwind-protect and catch are implemented as
;;; macros (throw is a built-in function).
(built-in-macro catch
(lambda (tag . body)
(if (null? body)
- (macro-error "catch with empty body"))
+ (macro-error "catch with empty body"))
(let ((tagsym (gensym)))
`(lexical-let ((,tagsym ,tag))
((guile-primitive catch)
- #t
- (lambda () ,@body)
- ,(let* ((dummy-key (gensym))
- (elisp-key (gensym))
- (value (gensym))
- (arglist `(,dummy-key ,elisp-key ,value)))
- `(with-always-lexical ,arglist
- (lambda ,arglist
- (if (eq ,elisp-key ,tagsym)
+ #t
+ (lambda () ,@body)
+ ,(let* ((dummy-key (gensym))
+ (elisp-key (gensym))
+ (value (gensym))
+ (arglist `(,dummy-key ,elisp-key ,value)))
+ `(with-always-lexical
+ ,arglist
+ (lambda ,arglist
+ (if (eq ,elisp-key ,tagsym)
,value
((guile-primitive throw) ,dummy-key ,elisp-key
- ,value))))))))))
+ ,value))))))))))
;;; unwind-protect is just some weaker construct as dynamic-wind, so
;;; straight-forward to implement.
(built-in-macro unwind-protect
(lambda (body . clean-ups)
(if (null? clean-ups)
- (macro-error "unwind-protect without cleanup code"))
+ (macro-error "unwind-protect without cleanup code"))
`((guile-primitive dynamic-wind)
- (lambda () nil)
- (lambda () ,body)
- (lambda () ,@clean-ups))))
+ (lambda () nil)
+ (lambda () ,body)
+ (lambda () ,@clean-ups))))
;;; Pop off the first element from a list or push one to it.
#:export (elisp))
(define-language elisp
- #:title "Emacs Lisp"
- #:reader (lambda (port env) (read-elisp port))
- #:printer write
- #:compilers `((tree-il . ,compile-tree-il)))
+ #:title "Emacs Lisp"
+ #:reader (lambda (port env) (read-elisp port))
+ #:printer write
+ #:compilers `((tree-il . ,compile-tree-il)))
HCoop / bpt / guile.git / commitdiff