mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
* Rename call-with-readline-completion-function' to with-readline-completion-function'.
* More tests for Elisp nil value. * Development work on Elisp translator.
This commit is contained in:
Neil Jerram
parent
f74fa0a0fd
commit
bbd26b5ae5
17 changed files with 606 additions and 412 deletions
|
|
@ -1,3 +1,8 @@
|
|||
2002-01-29 Neil Jerram <neil@ossau.uklinux.net>
|
||||
|
||||
* readline.scm (with-readline-completion-function): Renamed from
|
||||
`call-with-readline-completion-function'.
|
||||
|
||||
2001-11-30 Neil Jerram <neil@ossau.uklinux.net>
|
||||
|
||||
* Makefile.am (EXTRA_DIST): Refer to $(ice9_DATA) rather than
|
||||
|
|
|
|||
|
|
@ -187,7 +187,7 @@
|
|||
(set! *readline-completion-function* apropos-completion-function)
|
||||
))
|
||||
|
||||
(define-public (call-with-readline-completion-function completer thunk)
|
||||
(define-public (with-readline-completion-function completer thunk)
|
||||
"With @var{completer} as readline completion function, call @var{thunk}."
|
||||
(let ((old-completer *readline-completion-function*))
|
||||
(dynamic-wind
|
||||
|
|
|
|||
|
|
@ -1,3 +1,44 @@
|
|||
2002-01-29 Neil Jerram <neil@ossau.uklinux.net>
|
||||
|
||||
* transform.scm (transform-1, transform-2, transform-3,
|
||||
transform-list): Removed (unused).
|
||||
|
||||
* transform.scm, primitives/syntax.scm: Add commas everywhere
|
||||
before use of (guile) primitives in generated code, so that (lang
|
||||
elisp base) doesn't have to import bindings from (guile).
|
||||
|
||||
* base.scm: Move use-modules expressions inside the define-module,
|
||||
and add #:pure so that we don't import bindings from (guile).
|
||||
|
||||
2002-01-25 Neil Jerram <neil@ossau.uklinux.net>
|
||||
|
||||
* transform.scm (transform-application): Preserve source
|
||||
properties of original elisp expression by using cons-source.
|
||||
|
||||
* transform.scm: Don't handle special forms specially in the
|
||||
translator. Instead, define them as macros in ...
|
||||
|
||||
* primitives/syntax.scm: New file; special form definitions.
|
||||
|
||||
* primitives/fns.scm (run-hooks): Rewritten correctly.
|
||||
|
||||
* primitives/symprop.scm (symbol-value): Use `value'.
|
||||
|
||||
* internals/set.scm (value): New function.
|
||||
|
||||
* primitives/fns.scm: Use (lang elisp internals null), as null is
|
||||
no longer a primitive. Change generated #f values to %nil.
|
||||
|
||||
* internals/null.scm (null): Handle nil symbol.
|
||||
|
||||
* primitives/lists.scm (memq, member, assq, assoc): Handle all
|
||||
possible nil values.
|
||||
|
||||
* transform.scm (transformer): Translate `nil' and `t' to #nil and
|
||||
#t.
|
||||
|
||||
* base.scm: Remove setting of 'language read-option.
|
||||
|
||||
2001-11-03 Neil Jerram <neil@ossau.uklinux.net>
|
||||
|
||||
* README (Resources): Fill in missing URLs.
|
||||
|
|
|
|||
|
|
@ -1,34 +1,42 @@
|
|||
(define-module (lang elisp base))
|
||||
(define-module (lang elisp base)
|
||||
|
||||
;;; {Elisp Primitives}
|
||||
;;;
|
||||
;;; In other words, Scheme definitions of elisp primitives. This
|
||||
;;; should (ultimately) include everything that Emacs defines in C.
|
||||
;; Be pure. Nothing in this module requires most of the standard
|
||||
;; Guile builtins, and it creates a problem if this module has
|
||||
;; access to them, as @bind can dynamically change their values.
|
||||
#:pure
|
||||
|
||||
(use-modules (lang elisp primitives buffers)
|
||||
(lang elisp primitives features)
|
||||
(lang elisp primitives format)
|
||||
(lang elisp primitives fns)
|
||||
(lang elisp primitives guile)
|
||||
(lang elisp primitives keymaps)
|
||||
(lang elisp primitives lists)
|
||||
(lang elisp primitives load)
|
||||
(lang elisp primitives match)
|
||||
(lang elisp primitives numbers)
|
||||
(lang elisp primitives pure)
|
||||
(lang elisp primitives read)
|
||||
(lang elisp primitives signal)
|
||||
(lang elisp primitives strings)
|
||||
(lang elisp primitives symprop)
|
||||
(lang elisp primitives system)
|
||||
(lang elisp primitives time))
|
||||
;; But we do need a few builtins - import them here.
|
||||
#:use-module ((guile) #:select (@fop @bind nil-cond))
|
||||
|
||||
;;; Now switch into Emacs Lisp syntax.
|
||||
;; {Elisp Primitives}
|
||||
;;
|
||||
;; In other words, Scheme definitions of elisp primitives. This
|
||||
;; should (ultimately) include everything that Emacs defines in C.
|
||||
#:use-module (lang elisp primitives buffers)
|
||||
#:use-module (lang elisp primitives features)
|
||||
#:use-module (lang elisp primitives format)
|
||||
#:use-module (lang elisp primitives fns)
|
||||
#:use-module (lang elisp primitives guile)
|
||||
#:use-module (lang elisp primitives keymaps)
|
||||
#:use-module (lang elisp primitives lists)
|
||||
#:use-module (lang elisp primitives load)
|
||||
#:use-module (lang elisp primitives match)
|
||||
#:use-module (lang elisp primitives numbers)
|
||||
#:use-module (lang elisp primitives pure)
|
||||
#:use-module (lang elisp primitives read)
|
||||
#:use-module (lang elisp primitives signal)
|
||||
#:use-module (lang elisp primitives strings)
|
||||
#:use-module (lang elisp primitives symprop)
|
||||
#:use-module (lang elisp primitives syntax)
|
||||
#:use-module (lang elisp primitives system)
|
||||
#:use-module (lang elisp primitives time)
|
||||
|
||||
(use-modules (lang elisp transform))
|
||||
(read-set! keywords 'prefix)
|
||||
(read-set! language 'elisp)
|
||||
(set-module-transformer! (current-module) transformer)
|
||||
;; Now switch into Emacs Lisp syntax.
|
||||
#:use-syntax (lang elisp transform))
|
||||
|
||||
;(use-modules (lang elisp transform))
|
||||
;(read-set! keywords 'prefix)
|
||||
;(set-module-transformer! (current-module) transformer)
|
||||
|
||||
;;; Everything below here is written in Elisp.
|
||||
|
||||
|
|
|
|||
|
|
@ -3,4 +3,5 @@
|
|||
|
||||
(define (null obj)
|
||||
(or (not obj)
|
||||
(null? obj)))
|
||||
(null? obj)
|
||||
(eq? obj 'nil))) ; Should be removed.
|
||||
|
|
|
|||
|
|
@ -1,9 +1,18 @@
|
|||
(define-module (lang elisp internals set)
|
||||
#:use-module (lang elisp internals evaluation)
|
||||
#:use-module (lang elisp internals signal)
|
||||
#:export (set))
|
||||
#:export (set value))
|
||||
|
||||
;; Set SYM's variable value to VAL, and return VAL.
|
||||
(define (set sym val)
|
||||
(module-define! the-elisp-module sym val)
|
||||
val)
|
||||
|
||||
;; Return SYM's variable value. If it has none, signal an error if
|
||||
;; MUST-EXIST is true, just return #nil otherwise.
|
||||
(define (value sym must-exist)
|
||||
(if (module-defined? the-elisp-module sym)
|
||||
(module-ref the-elisp-module sym)
|
||||
(if must-exist
|
||||
(error "Symbol's value as variable is void:" sym)
|
||||
%nil)))
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ elisp_sources = \
|
|||
signal.scm \
|
||||
strings.scm \
|
||||
symprop.scm \
|
||||
syntax.scm \
|
||||
system.scm \
|
||||
time.scm
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
(define-module (lang elisp primitives fns)
|
||||
#:use-module (lang elisp internals fset))
|
||||
#:use-module (lang elisp internals set)
|
||||
#:use-module (lang elisp internals fset)
|
||||
#:use-module (lang elisp internals null))
|
||||
|
||||
(fset 'fset fset)
|
||||
(fset 'defalias fset)
|
||||
|
|
@ -12,11 +14,11 @@
|
|||
|
||||
(fset 'interactive-p
|
||||
(lambda ()
|
||||
#f))
|
||||
%nil))
|
||||
|
||||
(fset 'commandp
|
||||
(lambda (sym)
|
||||
(if (interactive-spec (fref sym)) #t #f)))
|
||||
(if (interactive-spec (fref sym)) #t %nil)))
|
||||
|
||||
(fset 'fboundp
|
||||
(lambda (sym)
|
||||
|
|
@ -32,14 +34,12 @@
|
|||
|
||||
(fset 'byte-code-function-p
|
||||
(lambda (object)
|
||||
#f))
|
||||
%nil))
|
||||
|
||||
(fset 'run-hooks
|
||||
(lambda (hooks)
|
||||
(cond ((null hooks))
|
||||
((list? hooks)
|
||||
(for-each (lambda (hook)
|
||||
(elisp-apply hook '()))
|
||||
hooks))
|
||||
(else
|
||||
(elisp-apply hooks '())))))
|
||||
(lambda hooks
|
||||
(for-each (lambda (hooksym)
|
||||
(for-each (lambda (fn)
|
||||
(elisp-apply fn '()))
|
||||
(value hooksym #f)))
|
||||
hooks)))
|
||||
|
|
|
|||
|
|
@ -46,10 +46,16 @@
|
|||
(fset sym
|
||||
(lambda (elt list)
|
||||
(if (null list)
|
||||
#f
|
||||
%nil
|
||||
(if (null elt)
|
||||
(or (proc #f list)
|
||||
(proc '() list))
|
||||
(proc '() list)
|
||||
(proc %nil list)
|
||||
(proc 'nil list)) ; 'nil shouldn't be
|
||||
; here, as it should
|
||||
; have been
|
||||
; translated by the
|
||||
; transformer.
|
||||
(proc elt list))))))
|
||||
'( memq member assq assoc)
|
||||
`(,memq ,member ,assq ,assoc))
|
||||
|
|
|
|||
|
|
@ -29,3 +29,5 @@
|
|||
(else (wta 'arrayp array 1)))))
|
||||
|
||||
(fset 'stringp string?)
|
||||
|
||||
(fset 'vector vector)
|
||||
|
|
|
|||
|
|
@ -22,9 +22,7 @@
|
|||
|
||||
(fset 'symbol-value
|
||||
(lambda (sym)
|
||||
(if (module-defined? the-elisp-module sym)
|
||||
(module-ref the-elisp-module sym)
|
||||
(error "Symbol's value as variable is void:" sym))))
|
||||
(value sym #t)))
|
||||
|
||||
(fset 'default-value 'symbol-value)
|
||||
|
||||
|
|
|
|||
359
lang/elisp/primitives/syntax.scm
Normal file
359
lang/elisp/primitives/syntax.scm
Normal file
|
|
@ -0,0 +1,359 @@
|
|||
(define-module (lang elisp primitives syntax)
|
||||
#:use-module (lang elisp internals evaluation)
|
||||
#:use-module (lang elisp internals fset)
|
||||
#:use-module (lang elisp internals trace)
|
||||
#:use-module (lang elisp transform))
|
||||
|
||||
;;; Define Emacs Lisp special forms as macros. This is much more
|
||||
;;; flexible than handling them specially in the translator: allows
|
||||
;;; them to be redefined, and hopefully allows better source location
|
||||
;;; tracking.
|
||||
|
||||
;;; {Variables}
|
||||
|
||||
(define (setq exp env)
|
||||
(cons begin
|
||||
(let loop ((sets (cdr exp)) (last-sym #f))
|
||||
(if (null? sets)
|
||||
(list last-sym)
|
||||
(cons `(,module-define! ,the-elisp-module
|
||||
(,quote ,(car sets))
|
||||
,(transformer (cadr sets)))
|
||||
(loop (cddr sets) (car sets)))))))
|
||||
|
||||
(fset 'setq
|
||||
(procedure->memoizing-macro setq))
|
||||
|
||||
(fset 'defvar
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(trc 'defvar (cadr exp))
|
||||
(if (null? (cddr exp))
|
||||
`(,quote ,(cadr exp))
|
||||
`(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
|
||||
,(setq (list (car exp) (cadr exp) (caddr exp)) env))
|
||||
;; (,macro-setq ,(cadr exp) ,(caddr exp)))
|
||||
(,quote ,(cadr exp)))))))
|
||||
|
||||
(fset 'defconst
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(trc 'defconst (cadr exp))
|
||||
`(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env)
|
||||
(,quote ,(cadr exp))))))
|
||||
|
||||
;;; {lambda, function and macro definitions}
|
||||
|
||||
;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
|
||||
;;; returns three values: (i) list of symbols for required arguments,
|
||||
;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
|
||||
;;; #f if there is no rest argument.
|
||||
(define (parse-formals formals)
|
||||
(letrec ((do-required
|
||||
(lambda (required formals)
|
||||
(if (null? formals)
|
||||
(values (reverse required) '() #f)
|
||||
(let ((next-sym (car formals)))
|
||||
(cond ((not (symbol? next-sym))
|
||||
(error "Bad formals (non-symbol in required list)"))
|
||||
((eq? next-sym '&optional)
|
||||
(do-optional required '() (cdr formals)))
|
||||
((eq? next-sym '&rest)
|
||||
(do-rest required '() (cdr formals)))
|
||||
(else
|
||||
(do-required (cons next-sym required)
|
||||
(cdr formals))))))))
|
||||
(do-optional
|
||||
(lambda (required optional formals)
|
||||
(if (null? formals)
|
||||
(values (reverse required) (reverse optional) #f)
|
||||
(let ((next-sym (car formals)))
|
||||
(cond ((not (symbol? next-sym))
|
||||
(error "Bad formals (non-symbol in optional list)"))
|
||||
((eq? next-sym '&rest)
|
||||
(do-rest required optional (cdr formals)))
|
||||
(else
|
||||
(do-optional required
|
||||
(cons next-sym optional)
|
||||
(cdr formals))))))))
|
||||
(do-rest
|
||||
(lambda (required optional formals)
|
||||
(if (= (length formals) 1)
|
||||
(let ((next-sym (car formals)))
|
||||
(if (symbol? next-sym)
|
||||
(values (reverse required) (reverse optional) next-sym)
|
||||
(error "Bad formals (non-symbol rest formal)")))
|
||||
(error "Bad formals (more than one rest formal)")))))
|
||||
|
||||
(do-required '() (cond ((list? formals)
|
||||
formals)
|
||||
((symbol? formals)
|
||||
(list '&rest formals))
|
||||
(else
|
||||
(error "Bad formals (not a list or a single symbol)"))))))
|
||||
|
||||
(define (transform-lambda exp)
|
||||
(call-with-values (lambda () (parse-formals (cadr exp)))
|
||||
(lambda (required optional rest)
|
||||
(let ((num-required (length required))
|
||||
(num-optional (length optional)))
|
||||
`(,lambda %--args
|
||||
(,let ((%--num-args (,length %--args)))
|
||||
(,cond ((,< %--num-args ,num-required)
|
||||
(,error "Wrong number of args (not enough required args)"))
|
||||
,@(if rest
|
||||
'()
|
||||
`(((,> %--num-args ,(+ num-required num-optional))
|
||||
(,error "Wrong number of args (too many args)"))))
|
||||
(else
|
||||
(@bind ,(append (map (lambda (i)
|
||||
(list (list-ref required i)
|
||||
`(,list-ref %--args ,i)))
|
||||
(iota num-required))
|
||||
(map (lambda (i)
|
||||
(let ((i+nr (+ i num-required)))
|
||||
(list (list-ref optional i)
|
||||
`(,if (,> %--num-args ,i+nr)
|
||||
(,list-ref %--args ,i+nr)
|
||||
#f))))
|
||||
(iota num-optional))
|
||||
(if rest
|
||||
(list (list rest
|
||||
`(,if (,> %--num-args
|
||||
,(+ num-required
|
||||
num-optional))
|
||||
(,list-tail %--args
|
||||
,(+ num-required
|
||||
num-optional))
|
||||
'())))
|
||||
'()))
|
||||
,@(map transformer (cddr exp)))))))))))
|
||||
|
||||
(define interactive-spec (make-fluid))
|
||||
|
||||
(define (set-not-subr! proc boolean)
|
||||
(set! (not-subr? proc) boolean))
|
||||
|
||||
(define (transform-lambda/interactive exp name)
|
||||
(fluid-set! interactive-spec #f)
|
||||
(let* ((x (transform-lambda exp))
|
||||
(is (fluid-ref interactive-spec)))
|
||||
`(,let ((%--lambda ,x))
|
||||
(,set-procedure-property! %--lambda (,quote name) (,quote ,name))
|
||||
(,set-not-subr! %--lambda #t)
|
||||
,@(if is
|
||||
`((,set! (,interactive-spec %--lambda) (,quote ,is)))
|
||||
'())
|
||||
%--lambda)))
|
||||
|
||||
(fset 'lambda
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(transform-lambda/interactive exp '<elisp-lambda>))))
|
||||
|
||||
(fset 'defun
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(trc 'defun (cadr exp))
|
||||
`(,begin (,fset (,quote ,(cadr exp))
|
||||
,(transform-lambda/interactive (cdr exp)
|
||||
(symbol-append '<elisp-defun:
|
||||
(cadr exp)
|
||||
'>)))
|
||||
(,quote ,(cadr exp))))))
|
||||
|
||||
(fset 'interactive
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(fluid-set! interactive-spec exp)
|
||||
#f)))
|
||||
|
||||
(fset 'defmacro
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(trc 'defmacro (cadr exp))
|
||||
(call-with-values (lambda () (parse-formals (caddr exp)))
|
||||
(lambda (required optional rest)
|
||||
(let ((num-required (length required))
|
||||
(num-optional (length optional)))
|
||||
`(,begin (,fset (,quote ,(cadr exp))
|
||||
(,procedure->memoizing-macro
|
||||
(,lambda (exp1 env1)
|
||||
(,trc (,quote using) (,quote ,(cadr exp)))
|
||||
(,let* ((%--args (,cdr exp1))
|
||||
(%--num-args (,length %--args)))
|
||||
(,cond ((,< %--num-args ,num-required)
|
||||
(,error "Wrong number of args (not enough required args)"))
|
||||
,@(if rest
|
||||
'()
|
||||
`(((,> %--num-args ,(+ num-required num-optional))
|
||||
(,error "Wrong number of args (too many args)"))))
|
||||
(else (,transformer
|
||||
(@bind ,(append (map (lambda (i)
|
||||
(list (list-ref required i)
|
||||
`(,list-ref %--args ,i)))
|
||||
(iota num-required))
|
||||
(map (lambda (i)
|
||||
(let ((i+nr (+ i num-required)))
|
||||
(list (list-ref optional i)
|
||||
`(,if (,> %--num-args ,i+nr)
|
||||
(,list-ref %--args ,i+nr)
|
||||
#f))))
|
||||
(iota num-optional))
|
||||
(if rest
|
||||
(list (list rest
|
||||
`(,if (,> %--num-args
|
||||
,(+ num-required
|
||||
num-optional))
|
||||
(,list-tail %--args
|
||||
,(+ num-required
|
||||
num-optional))
|
||||
'())))
|
||||
'()))
|
||||
,@(map transformer (cdddr exp)))))))))))))))))
|
||||
|
||||
;;; {Sequencing}
|
||||
|
||||
(fset 'progn
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
`(,begin ,@(map transformer (cdr exp))))))
|
||||
|
||||
(fset 'prog1
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
`(,let ((%res1 ,(transformer (cadr exp))))
|
||||
,@(map transformer (cddr exp))
|
||||
%res1))))
|
||||
|
||||
(fset 'prog2
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
`(,begin ,(transformer (cadr exp))
|
||||
(,let ((%res2 ,(transformer (caddr exp))))
|
||||
,@(map transformer (cdddr exp))
|
||||
%res2)))))
|
||||
|
||||
;;; {Conditionals}
|
||||
|
||||
(define <-- *unspecified*)
|
||||
|
||||
(fset 'if
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(let ((else-case (cdddr exp)))
|
||||
(cond ((null? else-case)
|
||||
`(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f))
|
||||
((null? (cdr else-case))
|
||||
`(nil-cond ,(transformer (cadr exp))
|
||||
,(transformer (caddr exp))
|
||||
,(transformer (car else-case))))
|
||||
(else
|
||||
`(nil-cond ,(transformer (cadr exp))
|
||||
,(transformer (caddr exp))
|
||||
(,begin ,@(map transformer else-case)))))))))
|
||||
|
||||
(fset 'and
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(cond ((null? (cdr exp)) #t)
|
||||
((null? (cddr exp)) (transformer (cadr exp)))
|
||||
(else
|
||||
(cons nil-cond
|
||||
(let loop ((args (cdr exp)))
|
||||
(if (null? (cdr args))
|
||||
(list (transformer (car args)))
|
||||
(cons (list not (transformer (car args)))
|
||||
(cons #f
|
||||
(loop (cdr args))))))))))))
|
||||
|
||||
(fset 'or
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(cond ((null? (cdr exp)) #f)
|
||||
((null? (cddr exp)) (transformer (cadr exp)))
|
||||
(else
|
||||
(cons nil-cond
|
||||
(let loop ((args (cdr exp)))
|
||||
(if (null? (cdr args))
|
||||
(list (transformer (car args)))
|
||||
(cons (transformer (car args))
|
||||
(cons <--
|
||||
(loop (cdr args))))))))))))
|
||||
|
||||
(fset 'cond
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(if (null? (cdr exp))
|
||||
#f
|
||||
(cons
|
||||
nil-cond
|
||||
(let loop ((clauses (cdr exp)))
|
||||
(if (null? clauses)
|
||||
'(#f)
|
||||
(let ((clause (car clauses)))
|
||||
(if (eq? (car clause) #t)
|
||||
(cond ((null? (cdr clause)) '(t))
|
||||
((null? (cddr clause))
|
||||
(list (transformer (cadr clause))))
|
||||
(else `((,begin ,@(map transformer (cdr clause))))))
|
||||
(cons (transformer (car clause))
|
||||
(cons (cond ((null? (cdr clause)) <--)
|
||||
((null? (cddr clause))
|
||||
(transformer (cadr clause)))
|
||||
(else
|
||||
`(,begin ,@(map transformer (cdr clause)))))
|
||||
(loop (cdr clauses)))))))))))))
|
||||
|
||||
(fset 'while
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
`((,letrec ((%--while (,lambda ()
|
||||
(,nil-cond ,(transformer (cadr exp))
|
||||
(,begin ,@(map transformer (cddr exp))
|
||||
(%--while))
|
||||
#f))))
|
||||
%--while)))))
|
||||
|
||||
;;; {Local binding}
|
||||
|
||||
(fset 'let
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
`(@bind ,(map (lambda (binding)
|
||||
(trc 'let binding)
|
||||
(if (pair? binding)
|
||||
`(,(car binding) ,(transformer (cadr binding)))
|
||||
`(,binding #f)))
|
||||
(cadr exp))
|
||||
,@(map transformer (cddr exp))))))
|
||||
|
||||
(fset 'let*
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(if (null? (cadr exp))
|
||||
`(begin ,@(map transformer (cddr exp)))
|
||||
(car (let loop ((bindings (cadr exp)))
|
||||
(if (null? bindings)
|
||||
(map transformer (cddr exp))
|
||||
`((@bind (,(let ((binding (car bindings)))
|
||||
(if (pair? binding)
|
||||
`(,(car binding) ,(transformer (cadr binding)))
|
||||
`(,binding #f))))
|
||||
,@(loop (cdr bindings)))))))))))
|
||||
|
||||
;;; {Exception handling}
|
||||
|
||||
(fset 'unwind-protect
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(trc 'unwind-protect (cadr exp))
|
||||
`(,let ((%--throw-args #f))
|
||||
(,catch #t
|
||||
(,lambda ()
|
||||
,(transformer (cadr exp)))
|
||||
(,lambda args
|
||||
(,set! %--throw-args args)))
|
||||
,@(map transformer (cddr exp))
|
||||
(,if %--throw-args
|
||||
(,apply ,throw %--throw-args))))))
|
||||
|
|
@ -3,9 +3,7 @@
|
|||
#:use-module (lang elisp internals fset)
|
||||
#:use-module (lang elisp internals evaluation)
|
||||
#:use-module (ice-9 session)
|
||||
#:export (transformer))
|
||||
|
||||
(define interactive-spec (make-fluid))
|
||||
#:export (transformer transform))
|
||||
|
||||
;;; {S-expressions}
|
||||
;;;
|
||||
|
|
@ -16,7 +14,9 @@
|
|||
;; Should be made mutating instead of constructing
|
||||
;;
|
||||
(define (transformer x)
|
||||
(cond ((null? x) '())
|
||||
(cond ((eq? x 'nil) %nil)
|
||||
((eq? x 't) #t)
|
||||
((null? x) '())
|
||||
((not (pair? x)) x)
|
||||
((and (pair? (car x))
|
||||
(eq? (caar x) 'quasiquote))
|
||||
|
|
@ -27,43 +27,29 @@
|
|||
; Escape to Scheme syntax
|
||||
((scheme) (cons 'begin (cdr x)))
|
||||
; Should be handled in reader
|
||||
((quote function) (cons 'quote (cars->nil (cdr x))))
|
||||
((quote function) `(,quote ,@(cars->nil (cdr x))))
|
||||
((quasiquote) (m-quasiquote x '()))
|
||||
((nil-cond) (transform-1 x))
|
||||
((let) (m-let x '()))
|
||||
((let*) (m-let* x '()))
|
||||
((if) (m-if x '()))
|
||||
((and) (m-and x '()))
|
||||
((or) (m-or x '()))
|
||||
((while) (m-while x '()))
|
||||
;((nil-cond) (transform-1 x))
|
||||
;((let) (m-let x '()))
|
||||
;((let*) (m-let* x '()))
|
||||
;((if) (m-if x '()))
|
||||
;((and) (m-and x '()))
|
||||
;((or) (m-or x '()))
|
||||
;((while) (m-while x '()))
|
||||
;((while) (cons macro-while (cdr x)))
|
||||
((prog1) (m-prog1 x '()))
|
||||
((prog2) (m-prog2 x '()))
|
||||
((progn begin) (cons 'begin (map transformer (cdr x))))
|
||||
((cond) (m-cond x '()))
|
||||
((lambda) (transform-lambda/interactive x '<elisp-lambda>))
|
||||
((defun) (m-defun x '()))
|
||||
((defmacro) (m-defmacro x '()))
|
||||
((setq) (m-setq x '()))
|
||||
((defvar) (m-defvar x '()))
|
||||
((defconst) (m-defconst x '()))
|
||||
((interactive) (fluid-set! interactive-spec x) #f)
|
||||
((unwind-protect) (m-unwind-protect x '()))
|
||||
;((prog1) (m-prog1 x '()))
|
||||
;((prog2) (m-prog2 x '()))
|
||||
;((progn) (cons 'begin (map transformer (cdr x))))
|
||||
;((cond) (m-cond x '()))
|
||||
;((lambda) (transform-lambda/interactive x '<elisp-lambda>))
|
||||
;((defun) (m-defun x '()))
|
||||
;((defmacro) (m-defmacro x '()))
|
||||
;((setq) (m-setq x '()))
|
||||
;((interactive) (fluid-set! interactive-spec x) #f)
|
||||
;((unwind-protect) (m-unwind-protect x '()))
|
||||
(else (transform-application x))))
|
||||
(else (syntax-error x))))
|
||||
|
||||
(define (m-unwind-protect exp env)
|
||||
(trc 'unwind-protect (cadr exp))
|
||||
`(let ((%--throw-args #f))
|
||||
(catch #t
|
||||
(lambda ()
|
||||
,(transformer (cadr exp)))
|
||||
(lambda args
|
||||
(set! %--throw-args args)))
|
||||
,@(transform-list (cddr exp))
|
||||
(if %--throw-args
|
||||
(apply throw %--throw-args))))
|
||||
|
||||
(define (m-quasiquote exp env)
|
||||
(cons 'quasiquote
|
||||
(map transform-inside-qq (cdr exp))))
|
||||
|
|
@ -78,185 +64,17 @@
|
|||
(else (cons (car x) (map transform-inside-qq (cdr x))))))
|
||||
(else
|
||||
(cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x))))))
|
||||
|
||||
(define (transform-1 x)
|
||||
(cons (car x) (map transformer (cdr x))))
|
||||
|
||||
(define (transform-2 x)
|
||||
(cons (car x)
|
||||
(cons (cadr x)
|
||||
(map transformer (cddr x)))))
|
||||
|
||||
(define (transform-3 x)
|
||||
(cons (car x)
|
||||
(cons (cadr x)
|
||||
(cons (caddr x)
|
||||
(map transformer (cdddr x))))))
|
||||
|
||||
(define (transform-list x)
|
||||
(map transformer x))
|
||||
|
||||
;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
|
||||
;;; returns three values: (i) list of symbols for required arguments,
|
||||
;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
|
||||
;;; #f if there is no rest argument.
|
||||
(define (parse-formals formals)
|
||||
(letrec ((do-required
|
||||
(lambda (required formals)
|
||||
(if (null? formals)
|
||||
(values (reverse required) '() #f)
|
||||
(let ((next-sym (car formals)))
|
||||
(cond ((not (symbol? next-sym))
|
||||
(error "Bad formals (non-symbol in required list)"))
|
||||
((eq? next-sym '&optional)
|
||||
(do-optional required '() (cdr formals)))
|
||||
((eq? next-sym '&rest)
|
||||
(do-rest required '() (cdr formals)))
|
||||
(else
|
||||
(do-required (cons next-sym required)
|
||||
(cdr formals))))))))
|
||||
(do-optional
|
||||
(lambda (required optional formals)
|
||||
(if (null? formals)
|
||||
(values (reverse required) (reverse optional) #f)
|
||||
(let ((next-sym (car formals)))
|
||||
(cond ((not (symbol? next-sym))
|
||||
(error "Bad formals (non-symbol in optional list)"))
|
||||
((eq? next-sym '&rest)
|
||||
(do-rest required optional (cdr formals)))
|
||||
(else
|
||||
(do-optional required
|
||||
(cons next-sym optional)
|
||||
(cdr formals))))))))
|
||||
(do-rest
|
||||
(lambda (required optional formals)
|
||||
(if (= (length formals) 1)
|
||||
(let ((next-sym (car formals)))
|
||||
(if (symbol? next-sym)
|
||||
(values (reverse required) (reverse optional) next-sym)
|
||||
(error "Bad formals (non-symbol rest formal)")))
|
||||
(error "Bad formals (more than one rest formal)")))))
|
||||
|
||||
(do-required '() (cond ((list? formals)
|
||||
formals)
|
||||
((symbol? formals)
|
||||
(list '&rest formals))
|
||||
(else
|
||||
(error "Bad formals (not a list or a single symbol)"))))))
|
||||
|
||||
(define (transform-lambda/interactive exp name)
|
||||
(fluid-set! interactive-spec #f)
|
||||
(let* ((x (transform-lambda exp))
|
||||
(is (fluid-ref interactive-spec)))
|
||||
`(let ((%--lambda ,x))
|
||||
(set-procedure-property! %--lambda 'name ',name)
|
||||
(set! (,not-subr? %--lambda) #t)
|
||||
,@(if is
|
||||
`((set! (,interactive-specification %--lambda) ',is))
|
||||
'())
|
||||
%--lambda)))
|
||||
|
||||
(define (transform-lambda exp)
|
||||
(call-with-values (lambda () (parse-formals (cadr exp)))
|
||||
(lambda (required optional rest)
|
||||
(let ((num-required (length required))
|
||||
(num-optional (length optional)))
|
||||
`(lambda %--args
|
||||
(let ((%--num-args (length %--args)))
|
||||
(cond ((< %--num-args ,num-required)
|
||||
(error "Wrong number of args (not enough required args)"))
|
||||
,@(if rest
|
||||
'()
|
||||
`(((> %--num-args ,(+ num-required num-optional))
|
||||
(error "Wrong number of args (too many args)"))))
|
||||
(else
|
||||
(@bind ,(append (map (lambda (i)
|
||||
(list (list-ref required i)
|
||||
`(list-ref %--args ,i)))
|
||||
(iota num-required))
|
||||
(map (lambda (i)
|
||||
(let ((i+nr (+ i num-required)))
|
||||
(list (list-ref optional i)
|
||||
`(if (> %--num-args ,i+nr)
|
||||
(list-ref %--args ,i+nr)
|
||||
#f))))
|
||||
(iota num-optional))
|
||||
(if rest
|
||||
(list (list rest
|
||||
`(if (> %--num-args
|
||||
,(+ num-required
|
||||
num-optional))
|
||||
(list-tail %--args
|
||||
,(+ num-required
|
||||
num-optional))
|
||||
'())))
|
||||
'()))
|
||||
,@(transform-list (cddr exp)))))))
|
||||
))))
|
||||
|
||||
(define (m-defun exp env)
|
||||
(trc 'defun (cadr exp))
|
||||
`(begin (,fset ',(cadr exp)
|
||||
,(transform-lambda/interactive (cdr exp)
|
||||
(symbol-append '<elisp-defun:
|
||||
(cadr exp)
|
||||
'>)))
|
||||
',(cadr exp)))
|
||||
|
||||
(define (m-defmacro exp env)
|
||||
(trc 'defmacro (cadr exp))
|
||||
(call-with-values (lambda () (parse-formals (caddr exp)))
|
||||
(lambda (required optional rest)
|
||||
(let ((num-required (length required))
|
||||
(num-optional (length optional)))
|
||||
`(begin (,fset ',(cadr exp)
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp1 env1)
|
||||
(,trc 'using ',(cadr exp))
|
||||
(let* ((%--args (cdr exp1))
|
||||
(%--num-args (length %--args)))
|
||||
(cond ((< %--num-args ,num-required)
|
||||
(error "Wrong number of args (not enough required args)"))
|
||||
,@(if rest
|
||||
'()
|
||||
`(((> %--num-args ,(+ num-required num-optional))
|
||||
(error "Wrong number of args (too many args)"))))
|
||||
(else (,transformer
|
||||
(@bind ,(append (map (lambda (i)
|
||||
(list (list-ref required i)
|
||||
`(list-ref %--args ,i)))
|
||||
(iota num-required))
|
||||
(map (lambda (i)
|
||||
(let ((i+nr (+ i num-required)))
|
||||
(list (list-ref optional i)
|
||||
`(if (> %--num-args ,i+nr)
|
||||
(list-ref %--args ,i+nr)
|
||||
#f))))
|
||||
(iota num-optional))
|
||||
(if rest
|
||||
(list (list rest
|
||||
`(if (> %--num-args
|
||||
,(+ num-required
|
||||
num-optional))
|
||||
(list-tail %--args
|
||||
,(+ num-required
|
||||
num-optional))
|
||||
'())))
|
||||
'()))
|
||||
,@(transform-list (cdddr exp)))))))))))))))
|
||||
|
||||
(define (transform-application x)
|
||||
`(@fop ,(car x)
|
||||
(,transformer-macro ,@(cdr x))))
|
||||
(cons-source x
|
||||
'@fop
|
||||
`(,(car x) (,transformer-macro ,@(cdr x)))))
|
||||
|
||||
(define transformer-macro
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(cons 'list (map transformer (cdr exp))))))
|
||||
|
||||
; (cons '@fop
|
||||
; (cons (car x)
|
||||
; (map transformer (cdr x)))))
|
||||
(let ((cdr cdr))
|
||||
(lambda (exp env)
|
||||
(cons 'list (map transformer (cdr exp)))))))
|
||||
|
||||
(define (cars->nil ls)
|
||||
(cond ((not (pair? ls)) ls)
|
||||
|
|
@ -264,151 +82,4 @@
|
|||
(else (cons (cars->nil (car ls))
|
||||
(cars->nil (cdr ls))))))
|
||||
|
||||
;;; {Special forms}
|
||||
;;;
|
||||
|
||||
(define (m-setq exp env)
|
||||
(cons 'begin
|
||||
(let loop ((sets (cdr exp)) (last-sym #f))
|
||||
(if (null? sets)
|
||||
(list last-sym)
|
||||
(cons `(module-define! ,the-elisp-module
|
||||
',(car sets)
|
||||
,(transformer (cadr sets)))
|
||||
(loop (cddr sets) (car sets)))))))
|
||||
|
||||
;(define (m-setq exp env)
|
||||
; (let* ((binder (car (last-pair env)))
|
||||
; (varvals (let loop ((ls (cdr exp)))
|
||||
; (if (null? ls)
|
||||
; '()
|
||||
; ;; Ensure existence only at macro expansion time
|
||||
; (let ((var (or (binder (car ls) #f)
|
||||
; (binder (car ls) #t))))
|
||||
; (if (not (variable-bound? var))
|
||||
; (variable-set! var #f))
|
||||
; (cons (list 'set! (car ls) (transformer (cadr ls)))
|
||||
; (loop (cddr ls))))))))
|
||||
; (cond ((null? varvals) '())
|
||||
; ((null? (cdr varvals)) (car varvals))
|
||||
; (else (cons 'begin varvals)))))
|
||||
|
||||
(define (m-let exp env)
|
||||
`(@bind ,(map (lambda (binding)
|
||||
(trc 'let binding)
|
||||
(if (pair? binding)
|
||||
`(,(car binding) ,(transformer (cadr binding)))
|
||||
`(,binding #f)))
|
||||
(cadr exp))
|
||||
,@(transform-list (cddr exp))))
|
||||
|
||||
(define (m-let* exp env)
|
||||
(if (null? (cadr exp))
|
||||
`(begin ,@(transform-list (cddr exp)))
|
||||
(car (let loop ((bindings (cadr exp)))
|
||||
(if (null? bindings)
|
||||
(transform-list (cddr exp))
|
||||
`((@bind (,(let ((binding (car bindings)))
|
||||
(if (pair? binding)
|
||||
`(,(car binding) ,(transformer (cadr binding)))
|
||||
`(,binding #f))))
|
||||
,@(loop (cdr bindings)))))))))
|
||||
|
||||
(define (m-prog1 exp env)
|
||||
`(,let ((%res1 ,(transformer (cadr exp))))
|
||||
,@(transform-list (cddr exp))
|
||||
%res1))
|
||||
|
||||
(define (m-prog2 exp env)
|
||||
`(begin ,(transformer (cadr exp))
|
||||
(,let ((%res2 ,(transformer (caddr exp))))
|
||||
,@(transform-list (cdddr exp))
|
||||
%res2)))
|
||||
|
||||
(define <-- *unspecified*)
|
||||
|
||||
(define (m-if exp env)
|
||||
(let ((else-case (cdddr exp)))
|
||||
(cond ((null? else-case)
|
||||
`(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f))
|
||||
((null? (cdr else-case))
|
||||
`(nil-cond ,(transformer (cadr exp))
|
||||
,(transformer (caddr exp))
|
||||
,(transformer (car else-case))))
|
||||
(else
|
||||
`(nil-cond ,(transformer (cadr exp))
|
||||
,(transformer (caddr exp))
|
||||
(begin ,@(transform-list else-case)))))))
|
||||
|
||||
(define (m-and exp env)
|
||||
(cond ((null? (cdr exp)) #t)
|
||||
((null? (cddr exp)) (transformer (cadr exp)))
|
||||
(else
|
||||
(cons 'nil-cond
|
||||
(let loop ((args (cdr exp)))
|
||||
(if (null? (cdr args))
|
||||
(list (transformer (car args)))
|
||||
(cons (list 'not (transformer (car args)))
|
||||
(cons #f
|
||||
(loop (cdr args))))))))))
|
||||
|
||||
(define (m-or exp env)
|
||||
(cond ((null? (cdr exp)) #f)
|
||||
((null? (cddr exp)) (transformer (cadr exp)))
|
||||
(else
|
||||
(cons 'nil-cond
|
||||
(let loop ((args (cdr exp)))
|
||||
(if (null? (cdr args))
|
||||
(list (transformer (car args)))
|
||||
(cons (transformer (car args))
|
||||
(cons <--
|
||||
(loop (cdr args))))))))))
|
||||
|
||||
(define m-cond
|
||||
(lambda (exp env)
|
||||
(if (null? (cdr exp))
|
||||
#f
|
||||
(cons
|
||||
'nil-cond
|
||||
(let loop ((clauses (cdr exp)))
|
||||
(if (null? clauses)
|
||||
'(#f)
|
||||
(let ((clause (car clauses)))
|
||||
(if (eq? (car clause) #t)
|
||||
(cond ((null? (cdr clause)) '(t))
|
||||
((null? (cddr clause))
|
||||
(list (transformer (cadr clause))))
|
||||
(else `((begin ,@(transform-list (cdr clause))))))
|
||||
(cons (transformer (car clause))
|
||||
(cons (cond ((null? (cdr clause)) <--)
|
||||
((null? (cddr clause))
|
||||
(transformer (cadr clause)))
|
||||
(else
|
||||
`(begin ,@(transform-list (cdr clause)))))
|
||||
(loop (cdr clauses))))))))))))
|
||||
|
||||
(define (m-while exp env)
|
||||
`(,let %while ()
|
||||
(nil-cond ,(transformer (cadr exp))
|
||||
(begin ,@(transform-list (cddr exp)) (%while))
|
||||
#f)))
|
||||
|
||||
(define (m-defvar exp env)
|
||||
(trc 'defvar (cadr exp))
|
||||
(if (null? (cddr exp))
|
||||
`',(cadr exp)
|
||||
`(begin (if (not (defined? ',(cadr exp)))
|
||||
(,macro-setq ,(cadr exp) ,(caddr exp)))
|
||||
',(cadr exp))))
|
||||
|
||||
(define (m-defconst exp env)
|
||||
(trc 'defconst (cadr exp))
|
||||
`(begin ,(m-setq (list (car exp) (cadr exp) (caddr exp)) env)
|
||||
',(cadr exp)))
|
||||
|
||||
;(export-mmacros
|
||||
; '(setq defun let let* if and or cond while prog1 prog2 progn)
|
||||
; (list m-setq m-defun m-let m-let* m-if m-and m-or m-cond m-while m-prog1 m-prog2 begin))
|
||||
|
||||
(define macro-setq (procedure->memoizing-macro m-setq))
|
||||
(define macro-while (procedure->memoizing-macro m-while))
|
||||
(define transform transformer)
|
||||
|
|
|
|||
|
|
@ -53,11 +53,11 @@
|
|||
(scm_swap_fluids, scm_swap_fluids_reverse), list.c (scm_null_p,
|
||||
scm_ilength, scm_append_x, scm_last_pair, scm_reverse,
|
||||
scm_reverse_x, scm_list_ref, scm_list_set_x, scm_list_cdr_set_x,
|
||||
scm_c_memq, scm_memv), load.c (scm_search_path), options.c
|
||||
(change_option_setting, scm_options), posix.c (environ_list_to_c),
|
||||
print.c (scm_iprlist), throw.c (scm_exit_status), vectors.c
|
||||
(scm_vector), weaks.c (scm_weak_vector): Use SCM_NULL_OR_NIL_P
|
||||
instead of SCM_NULLP.
|
||||
scm_c_memq, scm_memv, scm_member), load.c (scm_search_path),
|
||||
options.c (change_option_setting, scm_options), posix.c
|
||||
(environ_list_to_c), print.c (scm_iprlist), throw.c
|
||||
(scm_exit_status), vectors.c (scm_vector), weaks.c
|
||||
(scm_weak_vector): Use SCM_NULL_OR_NIL_P instead of SCM_NULLP.
|
||||
|
||||
* boolean.c (scm_not): Use `SCM_FALSEP || SCM_NILP' instead of
|
||||
just SCM_FALSEP.
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
2002-01-25 Neil Jerram <neil@ossau.uklinux.net>
|
||||
|
||||
* tests/load.test: New test; for search-path with Elisp
|
||||
nil-terminated lists for PATH and EXTENSIONS.
|
||||
|
||||
* tests/elisp.test: More tests for Scheme primitives that should
|
||||
accept Elisp nil-terminated lists.
|
||||
|
||||
2002-01-24 Neil Jerram <neil@ossau.uklinux.net>
|
||||
|
||||
* tests/elisp.test: More new tests for the Elisp nil value.
|
||||
|
|
|
|||
|
|
@ -109,12 +109,22 @@
|
|||
(pass-if "length (with backquoted list)"
|
||||
(= (length `(a b c . ,%nil)) 3))
|
||||
|
||||
(pass-if "write"
|
||||
(pass-if "write (%nil)"
|
||||
(string=? (with-output-to-string
|
||||
(lambda () (write %nil)))
|
||||
"#nil")) ; Hmmm... should be "()" ?
|
||||
|
||||
(pass-if "display (%nil)"
|
||||
(string=? (with-output-to-string
|
||||
(lambda () (display %nil)))
|
||||
"#nil")) ; Ditto.
|
||||
|
||||
(pass-if "write (list)"
|
||||
(string=? (with-output-to-string
|
||||
(lambda () (write (cons 'a %nil))))
|
||||
"(a)"))
|
||||
|
||||
(pass-if "display"
|
||||
(pass-if "display (list)"
|
||||
(string=? (with-output-to-string
|
||||
(lambda () (display (cons 'a %nil))))
|
||||
"(a)"))
|
||||
|
|
@ -186,6 +196,72 @@
|
|||
(list-set! l 6 44)
|
||||
(= (list-ref l 6) 44)))
|
||||
|
||||
(pass-if "list-cdr-set!"
|
||||
(let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
|
||||
(and (begin
|
||||
(list-cdr-set! l 4 44)
|
||||
(equal? l '(0 1 2 3 4 . 44)))
|
||||
(begin
|
||||
(list-cdr-set! l 3 `(new . ,%nil))
|
||||
(equal? l `(0 1 2 3 new . ,%nil))))))
|
||||
|
||||
(pass-if-exception "list-cdr-set!"
|
||||
exception:out-of-range
|
||||
(let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
|
||||
(list-cdr-set! l 6 44)))
|
||||
|
||||
(pass-if "memq"
|
||||
(equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil)))
|
||||
|
||||
(pass-if "memv"
|
||||
(equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil)))
|
||||
|
||||
(pass-if "member"
|
||||
(equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil)))
|
||||
|
||||
(pass-if "list->vector"
|
||||
(equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil))))
|
||||
|
||||
(pass-if "list->vector"
|
||||
(equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil))))
|
||||
|
||||
(pass-if "list->weak-vector"
|
||||
(equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil))))
|
||||
|
||||
(pass-if "sorted?"
|
||||
(and (sorted? `(1 2 3 . ,%nil) <)
|
||||
(not (sorted? `(1 6 3 . ,%nil) <))))
|
||||
|
||||
(pass-if "merge"
|
||||
(equal? (merge '(1 4 7 10)
|
||||
(merge `(2 5 8 11 . ,%nil)
|
||||
`(3 6 9 12 . ,%nil)
|
||||
<)
|
||||
<)
|
||||
`(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))
|
||||
|
||||
(pass-if "merge!"
|
||||
(equal? (merge! (copy-tree '(1 4 7 10))
|
||||
(merge! (copy-tree `(2 5 8 11 . ,%nil))
|
||||
(copy-tree `(3 6 9 12 . ,%nil))
|
||||
<)
|
||||
<)
|
||||
`(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))
|
||||
|
||||
(pass-if "sort"
|
||||
(equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))
|
||||
|
||||
(pass-if "stable-sort"
|
||||
(equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))
|
||||
|
||||
(pass-if "sort!"
|
||||
(equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
|
||||
'(1 3 4 5 8)))
|
||||
|
||||
(pass-if "stable-sort!"
|
||||
(equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
|
||||
'(1 3 4 5 8)))
|
||||
|
||||
)
|
||||
|
||||
(with-test-prefix "value preservation"
|
||||
|
|
|
|||
|
|
@ -114,4 +114,13 @@
|
|||
(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
|
||||
(try-search-with-extensions path "ugly.ss" extensions #f)
|
||||
|
||||
(if (defined? '%nil)
|
||||
;; Check that search-path accepts Elisp nil-terminated lists for
|
||||
;; PATH and EXTENSIONS.
|
||||
(with-test-prefix "elisp-nil"
|
||||
(set-cdr! (last-pair path) %nil)
|
||||
(set-cdr! (last-pair extensions) %nil)
|
||||
(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
|
||||
(try-search-with-extensions path "ugly.ss" extensions #f)))
|
||||
|
||||
(delete-tree temp-dir)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue