(declare (usual-integrations))
\f
-(define %subr
- (make-record-type
- "%subr"
- '(NAME ; To print like a real Emacs subr...
- PROCEDURE ; Same as apply hook's procedure.
- DOCSTRING
- PROMPT
- SPECIAL-FORM?)))
-
-(set-record-type-unparser-method!
- %subr
- (lambda (state object)
- ((unparser/standard-method "el:subr") state object)))
-
-(define %subr?
- (let ((%%subr? (record-predicate %subr)))
- (lambda (obj)
- (and (apply-hook? obj) (%%subr? (apply-hook-extra obj))))))
-
-(define %make-subr
- (let ((constructor (record-constructor
- %subr '(NAME PROCEDURE DOCSTRING PROMPT SPECIAL-FORM?))))
- (lambda (name procedure docstring prompt special-form?)
- (make-apply-hook
- procedure
- (constructor name procedure docstring prompt special-form?)))))
-
-(define (%subr-accessor field)
- (let ((getit (record-accessor %subr field)))
- (lambda (obj) (getit (apply-hook-extra obj)))))
-
-(define %subr-name (%subr-accessor 'NAME))
-
-(define %subr-procedure (%subr-accessor 'PROCEDURE))
-
-(define %subr-docstring (%subr-accessor 'DOCSTRING))
-
-(define %subr-prompt (%subr-accessor 'PROMPT))
-
-(define %subr-special-form? (%subr-accessor 'SPECIAL-FORM?))
\ No newline at end of file
+(define-structure (%subr
+ (conc-name %subr/)
+ (print-procedure
+ (unparser/standard-method "el:subr"))
+ (predicate %%subr?))
+ name ; To print like a real Emacs subr...
+ procedure ; Same as apply hook's procedure.
+ docstring
+ prompt
+ special-form?)
+(declare (integrate-operator %%subr?))
+
+(declare (integrate-operator %subr?))
+(define (%subr? obj)
+ (and (apply-hook? obj) (%%subr? (apply-hook-extra obj))))
+
+(define (%make-subr name procedure docstring prompt special-form?)
+ (make-apply-hook
+ procedure
+ (make-%subr name procedure docstring prompt special-form?)))
+
+(define-integrable (%subr-name subr)
+ (%subr/name (apply-hook-extra subr)))
+
+(define-integrable (%subr-procedure subr)
+ (%subr/procedure (apply-hook-extra subr)))
+
+(define-integrable (%subr-docstring subr)
+ (%subr/docstring (apply-hook-extra subr)))
+
+(define-integrable (%subr-prompt subr)
+ (%subr/prompt (apply-hook-extra subr)))
+
+(define-integrable (%subr-special-form? subr)
+ (%subr/special-form? (apply-hook-extra subr)))
\ No newline at end of file
(declare (usual-integrations))
\f
-(define %symbol-rt
- (make-record-type
- "el:symbol"
- '(NAME
- FUNCTION
- PLIST
- ;; For chaining together contents of obarray buckets.
- NEXT
- ;; An Edwin command created to reflect an Emacs command named by
- ;; this symbol.
- COMMAND
- ;; Methods...
- BOUND?
- UNBOUND!
- GET-VALUE
- SET-VALUE!
- GET-DEFAULT
- SET-DEFAULT!
- MAKE-LOCAL!
- MAKE-ALL-LOCAL!
- KILL-LOCAL!
- SET-DOCSTRING!)))
-
-(define-integrable %%symbol?
- (record-predicate %symbol-rt))
-(define-integrable %symbol/name
- (record-accessor %symbol-rt 'NAME))
-(define-integrable %symbol/function
- (record-accessor %symbol-rt 'FUNCTION))
-(define-integrable set-%symbol/function!
- (record-modifier %symbol-rt 'FUNCTION))
-(define-integrable %symbol/plist
- (record-accessor %symbol-rt 'PLIST))
-(define-integrable set-%symbol/plist!
- (record-modifier %symbol-rt 'PLIST))
-(define-integrable %symbol/next
- (record-accessor %symbol-rt 'NEXT))
-(define-integrable set-%symbol/next!
- (record-modifier %symbol-rt 'NEXT))
-(define-integrable %symbol/command
- (record-accessor %symbol-rt 'COMMAND))
-(define-integrable set-%symbol/command!
- (record-modifier %symbol-rt 'COMMAND))
-(define-integrable %symbol/bound?
- (record-accessor %symbol-rt 'BOUND?))
-(define-integrable set-%symbol/bound?!
- (record-modifier %symbol-rt 'BOUND?))
-(define-integrable %symbol/unbound!
- (record-accessor %symbol-rt 'UNBOUND!))
-(define-integrable set-%symbol/unbound!!
- (record-modifier %symbol-rt 'UNBOUND!))
-(define-integrable %symbol/get-value
- (record-accessor %symbol-rt 'GET-VALUE))
-(define-integrable set-%symbol/get-value!
- (record-modifier %symbol-rt 'GET-VALUE))
-(define-integrable %symbol/set-value!
- (record-accessor %symbol-rt 'SET-VALUE!))
-(define-integrable set-%symbol/set-value!!
- (record-modifier %symbol-rt 'SET-VALUE!))
-(define-integrable %symbol/get-default
- (record-accessor %symbol-rt 'GET-DEFAULT))
-(define-integrable set-%symbol/get-default!
- (record-modifier %symbol-rt 'GET-DEFAULT))
-(define-integrable %symbol/set-default!
- (record-accessor %symbol-rt 'SET-DEFAULT!))
-(define-integrable set-%symbol/set-default!!
- (record-modifier %symbol-rt 'SET-DEFAULT!))
-(define-integrable %symbol/make-local!
- (record-accessor %symbol-rt 'MAKE-LOCAL!))
-(define-integrable set-%symbol/make-local!!
- (record-modifier %symbol-rt 'MAKE-LOCAL!))
-(define-integrable %symbol/make-all-local!
- (record-accessor %symbol-rt 'MAKE-ALL-LOCAL!))
-(define-integrable set-%symbol/make-all-local!!
- (record-modifier %symbol-rt 'MAKE-ALL-LOCAL!))
-(define-integrable %symbol/kill-local!
- (record-accessor %symbol-rt 'KILL-LOCAL!))
-(define-integrable set-%symbol/kill-local!!
- (record-modifier %symbol-rt 'KILL-LOCAL!))
-(define-integrable %symbol/set-docstring!
- (record-accessor %symbol-rt 'SET-DOCSTRING!))
-(define-integrable set-%symbol/set-docstring!!
- (record-modifier %symbol-rt 'SET-DOCSTRING!))
-
-(set-record-type-unparser-method!
- %symbol-rt
- (lambda (state object)
- ((unparser/standard-method "el:symbol"
- (lambda (state object)
- (write-string (%symbol/name object)
- (unparser-state/port state))))
- state object)))
+;; Bummer. I liked the verbose but TAGS-visible definitions like
+;; (define-integrable symbol/name (record-accessor symbol-rt 'NAME))
+;; but I doubt they're integrable down to a %record-ref!!!
+
+(define-structure (%symbol
+ (conc-name %symbol/)
+ ;(constructor make-%symbol (name))
+ (constructor false)
+ (predicate %%symbol?)
+ ;(predicate false)
+ (print-procedure
+ (unparser/standard-method
+ "el:symbol"
+ (lambda (state object)
+ (write-string (%symbol/name object)
+ (unparser-state/port state))))))
+ (name "" read-only true)
+ (function +unbound+)
+ (plist '())
+ ;; For chaining together contents of obarray buckets.
+ (next '())
+ ;; An Edwin command created to reflect an Emacs command named by
+ ;; this symbol.
+ (command false)
+ ;; Methods...
+ (bound? false-procedure)
+ unbound!
+ get-value
+ set-value!
+ get-default
+ set-default!
+ make-local!
+ make-all-local!
+ kill-local!
+ set-docstring!)
+
+(declare (integrate-operator %%symbol?))
+
+;; Is there an easier way to get this completely inlined???
+;; (declare (integrate-operator %%symbol?)) doesn't quite do it.
+;; Or, will
+;;
+;; ((named-lambda (make-%symbol name) (%record %symbol...)) ???)
+;;
+;; get optimized into the equivalent of
+;;
+;; (%record %symbol ???...)
+;;
+;; anyway???
+(define-integrable (make-%symbol name)
+ (%record %symbol name +unbound+ '() '() false false-procedure '() '()
+ '() '() '() '() '() '() '()))
\f
;;;; Exported definitions
+(declare (integrate-operator %symbol?))
(define (%symbol? obj)
(or (null? obj)
(%%symbol? obj)))
(define +unbound+ "elisp unbound variable tag")
-(define %make-symbol
- (let ((constructor
- (record-constructor %symbol-rt
- '(NAME FUNCTION PLIST NEXT COMMAND BOUND?))))
- (lambda (name)
- (let ((symbol
- (constructor name +unbound+ '() '() false false-procedure)))
- ;; Don't make variable just because there's an Edwin variable with
- ;; the same name. Otherwise, things could get dicey with multiple
- ;; symbols with the same name -- e.g. an abbrev with the same name
- ;; as an editor variable.
- (%make-symbol-global! symbol)
- symbol))))
+(define-integrable (%make-symbol name)
+ (let ((symbol (make-%symbol name)))
+ ;; Don't make variable just because there's an Edwin variable with
+ ;; the same name. Otherwise, things could get dicey with multiple
+ ;; symbols with the same name -- e.g. an abbrev with the same name
+ ;; as an editor variable.
+ (%make-symbol-global! symbol)
+ symbol))
(declare (integrate-operator ->%symbol))
(define (->%symbol obj)
'()
obj))
-(define (%symbol-name symbol)
+(define-integrable (%symbol-name symbol)
(%symbol/name (->%symbol symbol)))
+(declare (integrate-operator %symbol-function))
(define (%symbol-function sym)
(let ((fun (%symbol/function (->%symbol sym))))
(if (eq? +unbound+ fun)
(error:%signal Qvoid-function (list sym))
fun)))
-(define (%set-symbol-function! sym function)
+(define-integrable (%set-symbol-function! sym function)
(set-%symbol/function! (->%symbol sym) function))
-(define (%symbol-fbound? sym)
+(define-integrable (%symbol-fbound? sym)
(let ((fun (%symbol/function (->%symbol sym))))
(not (eq? +unbound+ fun))))
-(define (%set-symbol-funbound! sym)
+(define-integrable (%set-symbol-funbound! sym)
(set-%symbol/function! (->%symbol sym) +unbound+)
unspecific)
-(define (%symbol-plist sym)
+(define-integrable (%symbol-plist sym)
(%symbol/plist (->%symbol sym)))
-(define (%set-symbol-plist! sym val)
+(define-integrable (%set-symbol-plist! sym val)
(set-%symbol/plist! (->%symbol sym) val))
(define (%get symbol property)
(else (loop (cdr (cdr plist)))))))
value)
-(define (%symbol-command sym)
+(define-integrable (%symbol-command sym)
(%symbol/command (->%symbol sym)))
-(define (%set-symbol-command! sym com)
+(define-integrable (%set-symbol-command! sym com)
(set-%symbol/command! (->%symbol sym) com))
(define-integrable (%symbol-bound? symbol)
table))))
(let loop ((defns defns))
(if (not (null? defns))
- (let ((defn (el:car defns)))
+ (let ((defn (%car defns)))
(el:define-abbrev table
- (el:car defn)
- (el:car (el:cdr defn))
- (el:car (el:cdr (el:cdr defn)))
- (el:car (el:cdr (el:cdr (el:cdr defn)))))
- (loop (el:cdr defns)))))))
+ (%car defn)
+ (%car (%cdr defn))
+ (%car (%cdr (%cdr defn)))
+ (%car (%cdr (%cdr (%cdr defn)))))
+ (loop (%cdr defns)))))))
'())
\f
(DEFVAR Qabbrev-table-name-list
(DEFUN (el:list . args)
"Return a newly created list whose elements are the arguments (any number)."
- (apply list args))
+ args)
(DEFUN (el:make-list length init)
"Return a newly created list of length LENGTH, with each element being INIT."
(define (DOcall op)
(CONTINUE
- (PUSH (apply
- el:funcall
- (DISCARD-list (fix:1+ (INDEX op Bcall)))))))
+ (PUSH
+ (let ((args (DISCARD-list (INDEX op Bcall))))
+ (%funcall (POP) args)))))
(define (DOunbind op)
;; Everything that needs to be unbound calls dispatch
op
(CONTINUE
(%save-window-excursion
- (lambda () (PUSH (apply el:progn (POP)))))))
+ (lambda () (PUSH (%progn (POP)))))))
(define (DOsave_restriction op)
op
(CONTINUE
(let ((body (POP)))
(PUSH (%catch (POP)
- (lambda () (el:eval body)))))))
+ (lambda () (%eval body)))))))
(define (DOunwind_protect op)
op
(UNBIND
(let ((unwind-forms (POP)))
#|(let ((value (dispatch)))
- (apply el:progn unwind-forms)
+ (%progn unwind-forms)
value)|#
(%unwind-protect
(lambda () (dispatch))
- (lambda () (apply el:progn unwind-forms))))))
+ (lambda () (%progn unwind-forms))))))
(define (DOcondition_case op)
op
(define (DOnth op)
op
(CONTINUE
- (let* ((list (POP))
+ (let* ((elts (POP))
(index (CHECK-NUMBER (POP))))
- (PUSH (el:nth index list)))))
+ (PUSH (el:nth index elts)))))
(define (DOsymbolp op)
op
(define (DOmemq op)
op
(CONTINUE
- (PUSH (let ((list (POP)))
- (el:memq (POP) list)))))
+ (PUSH (let ((elts (POP)))
+ (el:memq (POP) elts)))))
(define (DOnot op)
op
(define (DOcar op)
op
(CONTINUE
- (PUSH (el:car (POP)))))
+ (PUSH (%car (POP)))))
(define (DOcdr op)
op
(CONTINUE
- (PUSH (el:cdr (POP)))))
+ (PUSH (%cdr (POP)))))
(define (DOcons op)
op
Optional second arg RECORD-FLAG non-nil
means unconditionally put this command in the command-history.
Otherwise, this is done only if an arg is read using the minibuffer."
- (el:apply function
+ (%funcall function
(%interactive-arguments function (not (either-default? record)))))
(define (%call-interactively buffer command record?)
buffer
(lambda ()
(%set-symbol-value! Qthis-command function)
- (el:apply function args))))
+ (%funcall function args))))
;;; This is basically (edwin command-reader)interactive-arguments, hacked to
;;; record Emacs Lisp command invocations in the command-history as
'())
(else
(let ((old-keys-read keyboard-keys-read))
- (let ((arguments (el:eval specification)))
+ (let ((arguments (%eval specification)))
(if (not (list? arguments))
(error:wrong-type-datum arguments
"a list of interactive arguments"))
(error "The el:eval command is not intended for interactive use.")
'(error "The el:eval command is not intended for interactive use."))
(lambda (expression)
- (el:eval expression)))
+ (%eval expression)))
(DEFUN (el:prefix-numeric-value raw)
"Return numeric meaning of raw prefix argument ARG.
(define (wrong-type-argument predicate value)
(let ((new-value (error:%signal Qwrong-type-argument
(list predicate value))))
- (if (null? (el:funcall predicate new-value))
+ (if (null? (%funcall predicate (list new-value)))
(wrong-type-argument predicate new-value)
new-value)))
((%symbol? obj) Qt)
(else '())))
-;; Not an Emacs Lisp subr, but useful anyway.
(DEFUN (el:non-null-symbolp obj)
"T if OBJECT is a symbol, but not nil."
(if (%symbol? obj) Qt '()))
;;; Extract and set components of lists
-(DEFUN (el:car list)
+(DEFUN (el:car pair)
"Return the car of CONSCELL. If arg is nil, return nil."
- (cond ((pair? list) (car list))
- ((null? list) '())
- (else (el:car (wrong-type-argument Qlistp list)))))
+ (%car pair))
+
+(define (%car pair)
+ (cond ((pair? pair) (car pair))
+ ((null? pair) '())
+ (else (%car (wrong-type-argument Qlistp pair)))))
(DEFUN (el:car-safe object)
"Return the car of OBJECT if it is a cons cell, or else nil."
(if (pair? object) (car object) '()))
-(DEFUN (el:cdr list)
+(DEFUN (el:cdr pair)
"Return the cdr of CONSCELL. If arg is nil, return nil."
- (cond ((pair? list) (cdr list))
- ((null? list) '())
- (else (el:cdr (wrong-type-argument Qlistp list)))))
+ (%cdr pair))
+
+(define (%cdr pair)
+ (cond ((pair? pair) (cdr pair))
+ ((null? pair) '())
+ (else (%cdr (wrong-type-argument Qlistp pair)))))
(DEFUN (el:cdr-safe object)
"Return the cdr of OBJECT if it is a cons cell, or else nil."
"Set SYMBOL's default value to VAL. VAL is evaluated; SYMBOL is not.
The default value is seen in buffers that do not have their own values
for this variable."
- (%set-symbol-default! (CHECK-SYMBOL sym) (el:eval value)))
+ (%set-symbol-default! (CHECK-SYMBOL sym) (%eval value)))
(DEFUN (el:make-variable-buffer-local sym)
"Make VARIABLE have a separate value for each buffer.
"Save point (and mark), execute BODY, then restore point and mark.
Executes BODY just like PROGN. Point and mark values are restored
even in case of abnormal exit (throw or error)."
- (%save-excursion (lambda () (apply el:progn body))))
+ (%save-excursion (lambda () (%progn body))))
\f
(DEFUN (el:buffer-size)
"Return the number of characters in the current buffer."
Note: if you are using both save-excursion and save-restriction,
use save-excursion outermost."
- (%save-restriction (lambda () (apply el:progn body))))
+ (%save-restriction (lambda () (%progn body))))
(define (%save-restriction thunk)
(with-region-clipped!
(files "Subrs")
(parent (elisp))
(export (elisp)
+ %subr ;record type, used by inlined %subr?
%subr?
%make-subr
%subr-docstring
(files "Symbols")
(parent (elisp))
(export (elisp)
+ %symbol ;record type, used by inlined %symbol?
+ +unbound+ ;constant, used by %symbol-fbound?...
%symbol?
%make-symbol
%symbol-name
%intern
%intern-soft
%for-symbol
+ %make-symbol-global! ;procedure, used by %make-symbol
%make-symbol-variable!
%make-symbol-generic!
boolean-getter
(files "Buffers")
(parent (elisp))
(export (elisp)
+ elisp-current-buffer ;variable, used by %current-buffer...
%with-current-buffer
%current-buffer
%set-current-buffer!
(for-each (lambda (file)
(load (string-append file ".bin") package))
files))))
- (sf-and-load '("Buffers") '(ELISP BUFFERS))
- (sf-and-load '("Subrs") '(ELISP SUBRS))
- (sf-and-load '("Symbols") '(ELISP SYMBOLS))
- (sf-and-load '("Macros") '(ELISP SYNTAX-EXTENSIONS))
- (sf-and-load '("Reader") '(ELISP READER))
- (sf-and-load '("Misc" "lisp" "data" "eval" "fns" "lread" "buffer"
- "editfns" "fileio" "alloc" "minibuf" "search"
- "callint" "syntax" "cmds" "marker" "window"
- "keymap" "print" "indent" "process" "dired"
- "abbrev" "bytecode")
- '(ELISP)
- (environment-lookup (->environment '(ELISP))
- 'elisp-syntax-table)))
+ (fluid-let ((sf/default-declarations
+ (map* sf/default-declarations
+ (lambda (file)
+ `(INTEGRATE-EXTERNAL ,(string-append "edwin/" file)))
+ '("struct" "comman" "modes" "buffer" "edtstr"))))
+ (sf-and-load '("Buffers") '(ELISP BUFFERS))
+ (fluid-let ((sf/default-declarations
+ (cons '(INTEGRATE-EXTERNAL "Buffers")
+ sf/default-declarations)))
+ (sf-and-load '("Symbols") '(ELISP SYMBOLS))
+ (fluid-let ((sf/default-declarations
+ (cons '(INTEGRATE-EXTERNAL "Symbols")
+ sf/default-declarations)))
+ (sf-and-load '("Subrs") '(ELISP SUBRS))
+ (sf-and-load '("Macros") '(ELISP SYNTAX-EXTENSIONS))
+ (sf-and-load '("Reader") '(ELISP READER))
+ (sf-and-load '("lisp") '(ELISP))
+ (fluid-let ((sf/default-declarations
+ (append '((INTEGRATE-EXTERNAL "lisp")
+ (INTEGRATE-EXTERNAL "Subrs"))
+ sf/default-declarations)))
+ (sf-and-load '("Misc" "data" "eval" "fns" "lread" "buffer"
+ "editfns" "fileio" "alloc" "minibuf"
+ "search" "callint" "syntax" "cmds"
+ "marker" "window" "keymap" "print"
+ "indent" "process" "dired" "abbrev"
+ "bytecode")
+ '(ELISP)
+ (environment-lookup (->environment '(ELISP))
+ 'elisp-syntax-table)))))))
(cref2/generate-cref-unusual "elisp")
\ No newline at end of file
(list Qwrong-number-of-arguments Qerror))
(%put! Qwrong-number-of-arguments Qerror-message "Wrong number of arguments")
\f
+;;;; Utility procedures
+
+;; Scheme's `map' doesn't apply `proc' to the elements of `list' in
+;; any particular order...
+(declare (integrate-operator %map))
+(define (%map proc elts)
+ (if (pair? elts)
+ (let ((result (list (proc (car elts)))))
+ (let loop ((elts (cdr elts))
+ (end result))
+ (if (pair? elts)
+ (let ((new-end (list (proc (car elts)))))
+ (set-cdr! end new-end)
+ (loop (cdr elts) new-end))
+ result)))
+ '()))
+
+;; `args' had better be a list...
+(declare (integrate-operator %progn))
+(define (%progn args)
+ (if (null? args)
+ '()
+ (let loop ((args args))
+ (if (null? (cdr args))
+ (%eval (car args))
+ (begin
+ (%eval (car args))
+ (loop (cdr args)))))))
+\f
+;;;; Subrs
+
(DEFUN (el:or "e . args)
"Eval args until one of them yields non-NIL, then return that value.
The remaining args are not evalled at all.
If all args return NIL, return NIL."
- (if (pair? args)
- (or (el:eval (car args))
- (apply el:or (cdr args)))
- '()))
+ (let loop ((args args))
+ (if (pair? args)
+ (or (%eval (car args))
+ (loop (cdr args)))
+ '())))
(DEFUN (el:and "e . args)
"Eval args until one of them yields NIL, then return NIL.
If no arg yields NIL, return the last arg's value."
(if (pair? args)
(let loop ((args args))
- (let ((value (el:eval (car args)))
+ (let ((value (%eval (car args)))
(rest (cdr args)))
(if (null? value)
'()
"(if C T E...) if C yields non-NIL do T, else do E...
Returns the value of T or the value of the last of the E's.
There may be no E's; then if C yields NIL, the value is NIL."
- (let ((condition (el:eval c)))
+ (let ((condition (%eval c)))
(if (null? condition)
- (apply el:progn e)
- (el:eval t))))
+ (%progn e)
+ (%eval t))))
(DEFUN (el:cond "e . clauses)
"(cond CLAUSES...) tries each clause until one succeeds.
(if (null? clauses)
'()
(let ((clause (car clauses)))
- (let ((val (el:eval (car clause))))
+ (let ((val (%eval (car clause))))
(if (null? val)
(loop (cdr clauses))
(if (null? (cdr clause))
val
- (apply el:progn (cdr clause))))))))))
+ (%progn (cdr clause))))))))))
(DEFUN (el:progn "e . args)
"Eval arguments in sequence, and return the value of the last one."
- (if (null? args)
- '()
- (if (null? (cdr args))
- (el:eval (car args))
- (begin
- (el:eval (car args))
- (apply el:progn (cdr args))))))
+ (%progn args))
(DEFUN (el:prog1 "e . args)
"Eval arguments in sequence, then return the FIRST arg's value.
whose values are discarded."
(if (null? args)
'()
- (let ((val (el:eval (car args))))
- (apply el:progn (cdr args))
+ (let ((val (%eval (car args))))
+ (%progn (cdr args))
val)))
(DEFUN (el:prog2 "e . args)
(if (null? args)
'()
(begin
- (el:eval (car args))
+ (%eval (car args))
(if (null? (cdr args))
'()
- (let ((val (el:eval (cadr args))))
- (apply el:progn (cddr args))
+ (let ((val (%eval (cadr args))))
+ (%progn (cddr args))
val)))))
(DEFUN (el:setq "e . args)
"(setq SYM VAL SYM VAL ...) sets each SYM to the value of its VAL.
The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.
Each SYM is set before the next VAL is computed."
- (cond ((null? args) '())
- ((pair? args)
- (let ((sym (CHECK-SYMBOL (car args)))
- (val-rest (cdr args)))
- (let ((val (cond ((null? val-rest) '())
- ((not (pair? val-rest))
- (wrong-type-argument Qlistp val-rest))
- (else
- (el:eval (car val-rest))))))
- (%set-symbol-value! sym val)
- (if (or (null? val-rest) (null? (cdr val-rest)))
- val
- (apply el:setq (cdr val-rest))))))))
+ (let loop ((args args))
+ (cond ((null? args) '())
+ ((pair? args)
+ (let ((sym (CHECK-SYMBOL (car args)))
+ (val-rest (cdr args)))
+ (let ((val (cond ((null? val-rest) '())
+ ((not (pair? val-rest))
+ (wrong-type-argument Qlistp val-rest))
+ (else
+ (%eval (car val-rest))))))
+ (%set-symbol-value! sym val)
+ (if (or (null? val-rest) (null? (cdr val-rest)))
+ val
+ (loop (cdr val-rest)))))))))
(DEFUN (el:quote "e . args)
"Return the argument, without evaluating it. (quote x) yields x."
(if (and (not (%symbol-bound? sym))
(not (default-object? init)))
(begin
- (%set-symbol-value! sym (el:eval init))
+ (%set-symbol-value! sym (%eval init))
(if (not (default-object? doc))
(%put! sym Qvariable-documentation doc))))
sym))
(if (not (default-object? doc))
(%put! sym Qvariable-documentation doc))
(if (not (eq? (%symbol-bound? sym) 'EDWIN))
- (%set-symbol-value! sym (el:eval init)))
+ (%set-symbol-value! sym (%eval init)))
sym))
(DEFUN (el:user-variable-p var)
or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
Each VALUEFORM can refer to the symbols already bound by this VARLIST."
(if (null? varlist)
- (apply el:progn body)
+ (%progn body)
(varlist-receiver
varlist
(lambda (vars inits)
- (%specbind vars inits (lambda () (apply el:progn body)))))))
+ (%specbind vars inits (lambda () (%progn body)))))))
(DEFUN (el:let* "e varlist . body)
"(let VARLIST BODY...) binds variables according to VARLIST then executes BODY.
All the VALUEFORMs are evalled before any symbols are bound."
(let loop ((varlist varlist))
(if (null? varlist)
- (apply el:progn body)
+ (%progn body)
(varlist-receiver
- (list (el:car varlist))
+ (list (%car varlist))
(lambda (vars inits)
- (%specbind vars inits (lambda () (loop (el:cdr varlist)))))))))
+ (%specbind vars inits (lambda () (loop (%cdr varlist)))))))))
(define (varlist-receiver varlist receiver)
(let loop ((varlist varlist) (vars '()) (inits '()))
(if (null? varlist)
(receiver vars inits)
- (let ((elt (el:car varlist)))
+ (let ((elt (%car varlist)))
(if (%symbol? elt)
(loop (cdr varlist)
(cons elt vars)
(cons '() inits))
(loop (cdr varlist)
- (cons (el:car elt) vars)
- (cons (el:eval (el:car (el:cdr elt))) inits)))))))
+ (cons (%car elt) vars)
+ (cons (%eval (%car (%cdr elt))) inits)))))))
(define (%specbind vars inits thunk)
(let ((current-buffer (%current-buffer))
- (inside-state inits)
- (outside-state)
(+unbound+ "unbound"))
- (let ((safe-value
- (lambda (sym)
- (if (%symbol-bound? sym) (%symbol-value sym) +unbound+)))
- (safe-set!
- (lambda (sym val)
- (if (eq? val +unbound+)
- (%set-symbol-unbound! sym)
- (%set-symbol-value! sym val)))))
+ (let ((exchange!
+ (lambda ()
+ ;; When rewinding, (%current-buffer) may not be the same as
+ ;; current-buffer, so set it before establishing bindings and
+ ;; restore it afterwards.
+ (let ((old-buffer (%current-buffer)))
+ (%set-current-buffer! current-buffer)
+ (let loop ((syms vars)
+ (vals inits))
+ (if (pair? syms)
+ (let* ((symbol (car syms))
+ (new-value (car vals))
+ (old-value (if (%symbol-bound? symbol)
+ (%symbol-value symbol)
+ +unbound+)))
+ (if (eq? new-value +unbound+)
+ (%set-symbol-unbound! symbol)
+ (%set-symbol-value! symbol new-value))
+ (set-car! vals old-value)
+ (loop (cdr syms) (cdr vals)))))
+ (%set-current-buffer! old-buffer))
+ unspecific)))
(dynamic-wind
- (lambda ()
- ;; When rewinding, (%current-buffer) may not be the same as
- ;; current-buffer, so set it before establishing bindings and
- ;; restore it afterwards.
- (let ((old-buffer (%current-buffer)))
- (%set-current-buffer! current-buffer)
- (set! outside-state (map safe-value vars))
- (%set-current-buffer! old-buffer))
- (for-each safe-set! vars inside-state)
- (set! inside-state)
- unspecific)
+ exchange!
thunk
- (lambda ()
- ;; After (thunk), (%current-buffer) may be anything, so set and
- ;; restore it here too.
- (let ((old-buffer (%current-buffer)))
- (%set-current-buffer! current-buffer)
- (set! inside-state (map safe-value vars))
- (%set-current-buffer! old-buffer))
- (for-each safe-set! vars outside-state)
- (set! outside-state)
- unspecific)))))
+ exchange!))))
(DEFUN (el:while "e test . body)
"(while TEST BODY...) if TEST yields non-NIL, execute the BODY forms and repeat."
- (if (null? (el:eval test))
- '()
- (begin
- (apply el:progn body)
- (apply el:while test body))))
+ (let loop ()
+ (if (null? (%eval test))
+ '()
+ (begin
+ (%progn body)
+ (loop)))))
(DEFUN (el:macroexpand form #!optional env)
"If FORM is a macro call, expand it.
Return the ultimate expansion.
The second optional arg ENVIRONMENT species an environment of macro
definitions to shadow the loaded ones for use in file byte-compilation."
+ (%macroexpand form (if (default-object? env) '() env)))
+
+(define (%macroexpand form env)
(define (symbol-macro sym env)
(let ((tem (el:assq sym env)))
(if (%symbol? def)
(symbol-macro def env)
def))
- (let ((def (el:cdr tem)))
+ (let ((def (%cdr tem)))
(if (%symbol? def)
(symbol-macro def env)
(cons Qmacro def))))))
form
(if (not (%symbol? (car form)))
form
- (let ((def (symbol-macro (car form)
- (if (default-object? env) '() env))))
+ (let ((def (symbol-macro (car form) env)))
(cond ((not (pair? def))
form)
((eq? (car def) Qautoload)
- (if (el:car (el:nthcdr 4 def))
+ (if (%car (%cdr (%cdr (%cdr (%cdr def)))))
(begin
(do-autoload def (car form))
- (el:macroexpand form env))
+ (%macroexpand form env))
form))
((eq? (car def) Qmacro)
- (el:macroexpand (el:apply (cdr def) (cdr form)) env))
+ (%macroexpand (%funcall (cdr def) (cdr form)) env))
(else form))))))
(define condition-type:%throw
Then the BODY is executed. If no throw happens, the value of the last BODY
form is returned from catch. If a throw happens, it specifies the value to
return from catch."
- (%catch (el:eval tag) (lambda () (apply el:progn body))))
+ (%catch (%eval tag) (lambda () (%progn body))))
(define (%catch tag thunk)
(call-with-current-continuation
after executing the UNWINDFORMS.
If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway."
(%unwind-protect
- (lambda () (el:eval bodyform))
- (lambda () (apply el:progn unwindforms))))
+ (lambda () (%eval bodyform))
+ (lambda () (%progn unwindforms))))
(define (%unwind-protect protected-thunk unwind-thunk)
(dynamic-wind
(cond ((null? handlers) false)
((memq (caar handlers) generalizations)
(exit (if (null? var)
- (apply el:progn (CHECK-LIST (cdar handlers)))
+ (%progn (CHECK-LIST (cdar handlers)))
(%specbind
(list var)
(list (cons
(access-condition condition 'NAME)
(access-condition condition 'DATA)))
(lambda ()
- (apply el:progn
- (CHECK-LIST (cdar handlers))))))))
+ (%progn (CHECK-LIST (cdar handlers))))))))
(else (loop (cdr handlers)))))))
(lambda ()
- (el:eval bodyform))))))
+ (%eval bodyform))))))
(DEFUN (el:signal name data)
"Signal an error. Args are SIGNAL-NAME, and associated DATA.
(cond ((not (%symbol? funcar))
(error:%signal Qinvalid-function (list fun)))
((eq? Qlambda funcar)
- (not (null? (el:assq Qinteractive (cdr (cdr fun))))))
+ (not (null? (el:assq Qinteractive (cddr fun)))))
((eq? Qautoload funcar)
- (eq? Qt (el:car (el:cdr (el:cdr (el:cdr fun))))))
+ (eq? Qt (%car (%cdr (%cdr (%cdr fun))))))
(else '())))))))
(DEFUN (el:autoload function file #!optional docstring interactive macro_)
(DEFUN (el:eval form)
"Evaluate FORM and return its value."
+ (%eval form))
+
+;; Are apply-hooks any slower to apply than procedures?
+(define (%eval form)
(cond ((%symbol? form)
(%symbol-value form))
((not (pair? form))
(cond ((%subr? fun)
(if (%subr-special-form? fun)
(apply fun original-args)
- (apply fun (%map el:eval original-args))))
+ (apply fun (%map %eval original-args))))
((not (and (pair? fun)
(%symbol? (car fun))))
(loop (%function*
(error:%signal Qinvalid-function (list fun)))))
((eq? (car fun) Qlambda)
- (funcall-lambda fun (%map el:eval original-args)))
+ (funcall-lambda fun (%map %eval original-args)))
((eq? (car fun) Qmacro)
- (el:eval (el:apply (cdr fun) original-args)))
+ (%eval (%funcall (cdr fun) original-args)))
((eq? (car fun) Qautoload)
(do-autoload fun original-fun)
(loop (%function* original-fun)))
"Call FUNCTION, passing remaining arguments to it. The last argument
is a list of arguments to pass.
Thus, (apply '+ 1 2 '(3 4)) returns 10."
- (apply el:funcall fun (append! (except-last-pair args)
- (car (last-pair args)))))
+ (%funcall fun (append! (except-last-pair args) (car (last-pair args)))))
(DEFUN (el:funcall func . args)
"Call first argument as a function, passing remaining arguments to it.
Thus, (funcall 'cons 'x 'y) returns (x . y)."
+ (%funcall func args))
+
+(define (%funcall func args)
(let retry ((fun (%function* func))
(numargs (length args)))
(cond ((%subr? fun)
(cond ((%subr-special-form? fun)
- (el:apply (error:%signal Qinvalid-function (list fun))
+ (%funcall (error:%signal Qinvalid-function (list fun))
args))
((not (procedure-arity-valid? fun numargs))
- (el:apply (error:%signal Qwrong-number-of-arguments
+ (%funcall (error:%signal Qwrong-number-of-arguments
(list numargs))
args))
(else (apply fun args))))
(error:%signal Qwrong-number-of-arguments
(list fun (length orig-args))))
(%specbind vars inits
- (lambda () (apply el:progn (cdr (cdr fun))))))
+ (lambda () (%progn (cddr fun)))))
((eq? (car syms) Qand-rest)
(loop (cdr (cdr syms))
()
(if (string? (car body))
(car body)
false)))
- (else false))))
-\f
-;;;; Utility procedures
-
-(define (%map proc list)
- ;; Scheme's `map' doesn't apply `proc' to the elements of `list' in
- ;; any particular order...
- (reverse!
- (let loop ((list list)
- (results '()))
- (if (pair? list)
- (loop (cdr list)
- (cons (proc (car list)) results))
- results))))
\ No newline at end of file
+ (else false))))
\ No newline at end of file
Qt
"*Non-nil means when reading a filename start with default dir in minibuffer.")
-(DEFVAR Qvms-stmlf-recfm
+#|(DEFVAR Qvms-stmlf-recfm
'()
"*Non-nil means write new files with record format `stmlf'.
-nil means use format `var'. This variable is meaningful only on VMS.")
+nil means use format `var'. This variable is meaningful only on VMS.")|#
\f
(DEFUN (el:file-name-directory file)
"Return the directory component in file name NAME.
(cons (substring string start index) (loop (+ 1 index)))
(list (substring string start end))))))
-(define (list->commaized-string list comma)
+(define (list->commaized-string strings comma)
(apply string-append
- (let loop ((input list)
+ (let loop ((input strings)
(output ()))
(if (pair? input)
(loop (cdr input)
(cons comma (cons (car input) output)))
(reverse! output)))))
-(define (components-string list delimiter)
+(define (components-string strings delimiter)
(apply string-append
- (if (pair? list)
- (cons (car list)
- (let loop ((input (cdr list))
+ (if (pair? strings)
+ (cons (car strings)
+ (let loop ((input (cdr strings))
(output ()))
(if (pair? input)
(loop (cdr input)
(error:%signal Qargs-out-of-range (list string from to)))
(substring string from to))))
-(DEFUN (el:nthcdr n list)
+(DEFUN (el:nthcdr n elts)
"Takes cdr N times on LIST, returns the result."
(let ((n (CHECK-NUMBER n)))
- (cond ((<= n 0) list)
- ((< (length list) n) '())
- (else (list-tail list n)))))
+ (cond ((<= n 0) elts)
+ ((< (length elts) n) '())
+ (else (list-tail elts n)))))
-(DEFUN (el:nth n list)
+(DEFUN (el:nth n elts)
"Returns the Nth element of LIST.
N counts from zero. If LIST is not that long, nil is returned."
(let ((n (max (CHECK-NUMBER n) 0))
- (list (CHECK-LIST list)))
- (cond ((< (length list) n) '())
- (else (list-ref list n)))))
+ (elts (CHECK-LIST elts)))
+ (cond ((< (length elts) n) '())
+ (else (list-ref elts n)))))
(DEFUN (el:elt seq n)
"Returns element of SEQUENCE at index N."
(el:aref seq n))
(else (el:elt (wrong-type-argument Qsequencep seq) n))))
-(DEFUN (el:memq elt list)
+(DEFUN (el:memq elt elts)
"Returns non-nil if ELT is an element of LIST. Comparison done with EQ.
The value is actually the tail of LIST whose car is ELT."
- (let loop ((tail list))
+ (let loop ((tail elts))
(cond ((null? tail) '())
((el:eq (el:car tail) elt) tail)
(else (loop (el:cdr tail))))))
-(DEFUN (el:assq key list)
+(DEFUN (el:assq key alist)
"Returns non-nil if ELT is the car of an element of LIST. Comparison done with eq.
The value is actually the element of LIST whose car is ELT."
- (let loop ((tail list))
+ (let loop ((tail alist))
(if (null? tail)
'()
(let ((elt (el:car tail)))
elt
(loop (cdr tail)))))))
-(DEFUN (el:assoc key list)
+(DEFUN (el:assoc key alist)
"Returns non-nil if ELT is the car of an element of LIST. Comparison done with equal.
The value is actually the element of LIST whose car is ELT."
- (let loop ((tail list))
+ (let loop ((tail alist))
(if (null? tail)
'()
(let ((elt (el:car tail)))
elt
(loop (cdr tail)))))))
-(DEFUN (el:rassq key list)
+(DEFUN (el:rassq key alist)
"Returns non-nil if ELT is the cdr of an element of LIST. Comparison done with EQ.
The value is actually the element of LIST whose cdr is ELT."
- (let loop ((tail list))
+ (let loop ((tail alist))
(if (null? tail)
'()
(let ((elt (el:car tail)))
elt
(loop (cdr tail)))))))
-(DEFUN (el:delq elt list)
+(DEFUN (el:delq elt elts)
"Deletes by side effect any occurrences of ELT as a member of LIST.
The modified LIST is returned.
If the first member of LIST is ELT, there is no way to remove it by side effect;
therefore, write (setq foo (delq element foo)) to be sure of changing foo."
- (let loop ((tail list)
+ (let loop ((tail elts)
(prev '()))
- (cond ((null? tail) list)
- ((el:eq (el:car tail) elt)
+ (cond ((null? tail) elts)
+ ((el:eq (%car tail) elt)
(let ((cdr (cdr tail)))
(if (null? prev)
- (set! list cdr)
+ (set! elts cdr)
(set-cdr! prev cdr))
(loop cdr prev)))
(else (loop (cdr tail) tail)))))
-(DEFUN (el:nreverse list)
+(DEFUN (el:nreverse elts)
"Reverses LIST by modifying cdr pointers. Returns the beginning of the reversed list."
- (let loop ((tail list)
+ (let loop ((tail elts)
(prev '()))
(if (null? tail)
prev
- (let ((next (el:cdr tail)))
+ (let ((next (%cdr tail)))
(set-cdr! tail prev)
(loop next tail)))))
-(DEFUN (el:reverse list)
+(DEFUN (el:reverse elts)
"Reverses LIST, copying. Returns the beginning of the reversed list.
See also the function nreverse, which is used more often."
- (let loop ((tail list)
+ (let loop ((tail elts)
(result '()))
(if (null? tail)
result
- (loop (el:cdr tail) (cons (el:car tail) result)))))
+ (loop (%cdr tail) (cons (%car tail) result)))))
-(DEFUN (el:sort list pred)
+(DEFUN (el:sort elts pred)
"Sort LIST, stably, comparing elements using PREDICATE.
Returns the sorted list. LIST is modified by side effects.
PREDICATE is called with two elements of LIST, and should return T
;; tail of list isn't a list.) (Scheme just drops a bogus tail.) (Just
;; for laughs, accept replacement [sub]list value returned by
;; wrong-type-argument.)
- (let loop ((tail list)
+ (let loop ((tail elts)
(prev '()))
(cond ((null? tail))
((pair? tail)
(else
(if (null? prev)
(begin
- (set! list (wrong-type-argument Qlistp tail))
- (loop list '()))
+ (set! elts (wrong-type-argument Qlistp tail))
+ (loop elts '()))
(begin
(set-cdr! prev (wrong-type-argument Qlistp tail))
(loop (cdr (cdr prev)) (cdr prev)))))))
- (sort list (lambda (elt1 elt2)
- (el:funcall pred elt1 elt2))))
+ (sort elts (lambda (elt1 elt2)
+ (%funcall pred (list elt1 elt2)))))
(DEFUN (el:get sym prop)
"Return the value of SYMBOL's PROPNAME property.
(lambda ()
(mapcar1 seq (lambda (elt)
(if need-sep? (display sep) (set! need-sep? #!true))
- (display (el:funcall fn elt))))))))
+ (display (%funcall fn (list elt)))))))))
-(DEFUN (el:mapcar fn list)
+(DEFUN (el:mapcar fn elts)
"Apply FUNCTION to each element of LIST, and make a list of the results.
The result is a list just as long as LIST."
- (cond ((null? list) '())
- ((pair? list) (%mapcar-list fn list))
- ((and (event-distributor? list)
+ (cond ((null? elts) '())
+ ((pair? elts) (%mapcar-list fn elts))
+ ((and (event-distributor? elts)
(or (eq? fn Qfuncall)
(eq? fn el:funcall)))
- (event-distributor/invoke! list))
- (else (wrong-type-argument Qlistp list))))
+ (event-distributor/invoke! elts))
+ (else (wrong-type-argument Qlistp elts))))
-(define (%mapcar-list fn list)
- (let loop ((tail list)(res '()))
+(define (%mapcar-list fn elts)
+ (let loop ((tail elts)(res '()))
(cond ((null? tail) (el:nreverse res))
((pair? tail)
- (loop (cdr tail) (cons (el:funcall fn (car tail)) res)))
+ (loop (cdr tail) (cons (%funcall fn (cons (car tail) '())) res)))
(else (wrong-type-argument Qlistp tail)))))
(DEFUN (el:y-or-n-p prompt)
x
(wrong-type-argument Qprocessp x)))
+(declare (integrate-operator CHECK-PROCESS-COERCE))
(define (CHECK-PROCESS-COERCE x)
;; Ala get_process in process.c.
(let ((proc (if (null? x)
proc)))))
(if (process? proc)
proc
- (CHECK-PROCESS-COERCE
- (error:%signal
- Qerror
- (if (null? x)
- (list "Current buffer has no process")
- (list "Process %s does not exist" x)))))))
+ (error:%signal
+ Qerror
+ (if (null? x)
+ (list "Current buffer has no process")
+ (list "Process %s does not exist" x))))))
(declare (integrate-operator CHECK-NUMBER))
(define (CHECK-NUMBER x)
x
(wrong-type-argument Qmarkerp x)))
-(define (CHECK-MARKER-COERCE-INT x buffer)
+(define-integrable (CHECK-MARKER-COERCE-INT x buffer)
;; Convert from an Emacs int representing a buffer position into an
;; Edwin marker.
(let* ((group (buffer-group buffer))
((> pt max) max)
(else pt)))))
+(declare (integrate-operator CHECK-NUMBER-COERCE-MARKER))
(define (CHECK-NUMBER-COERCE-MARKER x)
;; Convert from an Emacs int or marker into a number.
(cond ((integer? x) x)
((mark? x)
(%mark->number x))
(else
- (CHECK-NUMBER-COERCE-MARKER
- (wrong-type-argument Qinteger-or-marker-p x)))))
+ (wrong-type-argument Qinteger-or-marker-p x))))
+(declare (integrate-operator CHECK-POSITION-COERCE-MARKER))
(define (CHECK-POSITION-COERCE-MARKER x)
;; Convert from an Emacs int or marker into a buffer position.
(cond ((integer? x) (-1+ x))
(if (and (mark-group x) (mark-index x))
(begin
;; Enforce our expectation of Emacs markers.
- (mark-permanent! x)
+ ;; Not if it's expensive!
+ ;;(mark-permanent! x)
(%mark->position x))
- (CHECK-POSITION-COERCE-MARKER
- (error:%signal Qerror
- (list "Marker does not point anywhere" x)))))
+ (error:%signal Qerror (list "Marker does not point anywhere" x))))
(else
- (CHECK-POSITION-COERCE-MARKER
- (wrong-type-argument Qinteger-or-marker-p x)))))
+ (wrong-type-argument Qinteger-or-marker-p x))))
+(declare (integrate-operator CHECK-REGION))
(define (CHECK-REGION start end buffer)
;; aka validate_region in GNU Emacs.
(let ((group (buffer-group buffer))
table
(wrong-type-argument Qcompletion-table-p table)))
-(DEFUN (el:completion-table-p object)
- "T if OBJECT is an alist or obarray."
- (if (completion-table? object) Qt '()))
-
-(define (completion-table? object)
- (cond ((pair? object)
- (for-all? object
- (lambda (entry)
- (and (pair? entry) (string? (car entry))))))
- ((vector? object)
- (for-all-elts? object
- (lambda (element)
- (or (%symbol? element) (zero? element)))))
- (else false)))
-
-(define (for-all-elts? vector predicate)
- (let ((length (vector-length vector)))
- (let loop ((index 0))
- (if (< index length)
- (let ((element (vector-ref vector index)))
- (if (predicate element)
- (loop (1+ index))
- false))
- true))))
-
(declare (integrate-operator CHECK-KEYMAP))
(define (CHECK-KEYMAP keymap)
(let ((comtab (keymap->comtab keymap)))
(let ((filename (el:expand-file-name name (car prefixes))))
(if (pathname-absolute? (->pathname filename))
filename
- (el:expand-file-name filename (el:symbol-value
+ (el:expand-file-name filename (%symbol-value
Qdefault-directory))))))
(if (pathname-absolute? (->pathname filename))
(let suffix-loop ((suffixes suffixes))
(begin
(set-%function-input-port-state/peeked-char! state ())
unread-char)
- (el:funcall (%function-input-port-state/function state)))))
+ (%funcall (%function-input-port-state/function state) '()))))
(define (%function-input-port/peek-char port)
(let* ((state (port/state port))
(unread-char (%function-input-port-state/peeked-char state)))
(or unread-char
(let ((char
- (el:funcall (%function-input-port-state/function state))))
+ (%funcall (%function-input-port-state/function state) '())))
(set-%function-input-port-state/peeked-char! state char)
char))))
(list Qload-in-progress)
(list Qt)
(lambda ()
- (readevalloop stream el:eval false)))
+ (readevalloop stream %eval false)))
(close-input-port stream)
(if (not nomessage?) ;(and (not noninteractive?) nomessage?)
(message "Loading " str "...done"))
(lambda ()
(let ((buffer (%current-buffer)))
(set-buffer-point! buffer (buffer-start buffer))
- (readevalloop buffer el:eval print?)))))))
+ (readevalloop buffer %eval print?)))))))
'())
(DEFUN (el:eval-region b e #!optional printflag)
(lambda ()
(set-buffer-point! buffer (region-start region))
(region-clip! region)
- (readevalloop buffer el:eval print?))))))
+ (readevalloop buffer %eval print?))))))
(if (not print?)
(%save-excursion kernel)
(kernel))))))
it defaults to the value of obarray."
(let ((str (CHECK-STRING str))
(ob (check-obarray (if (either-default? obarray)
- (el:symbol-value Qobarray)
+ (%symbol-value Qobarray)
obarray))))
(%intern str ob)))
it defaults to the value of obarray."
(let ((str (CHECK-STRING str))
(ob (check-obarray (if (either-default? obarray)
- (el:symbol-value Qobarray)
+ (%symbol-value Qobarray)
obarray))))
(%intern-soft str ob)))
"Call FUNCTION on every symbol in OBARRAY.
OBARRAY defaults to the value of obarray."
(let ((obarray (check-obarray (if (either-default? obarray)
- (el:symbol-value Qobarray)
+ (%symbol-value Qobarray)
obarray))))
- (%for-symbol (lambda (symbol) (el:funcall function symbol)) obarray))
+ (%for-symbol (lambda (symbol) (%funcall function (list symbol))) obarray))
'())
\ No newline at end of file
"Return value of Lisp expression read using the minibuffer.
Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
is a string to insert in the minibuffer before reading."
- (el:eval (el:read-minibuffer prompt (if (default-object? initial-contents)
- false
- initial-contents))))
+ (%eval (el:read-minibuffer prompt (if (default-object? initial-contents)
+ false
+ initial-contents))))
(DEFUN (el:read-string prompt #!optional initial-input)
"Read a string from the minibuffer, prompting with string PROMPT.
(let ((string (CHECK-STRING string))
(pred (if (default-object? pred) false pred)))
(if (and (not (pair? alist)) (not (vector? alist)))
- (el:funcall alist string (or pred '()) '())
+ (%funcall alist (list string (or pred '()) '()))
(let ((completion (%try-completion string alist pred)))
(case completion
(#f '())
alist
(lambda (eltstring elt)
(if (and (prefix? string eltstring)
- (if pred (not (null? (el:funcall pred elt))) true))
+ (if pred (not (null? (%funcall pred (list elt)))) true))
(begin
(set! matchcount (1+ matchcount))
(if (not bestmatch)
(let ((string (CHECK-STRING string))
(pred (if (default-object? pred) false pred)))
(if (and (not (pair? alist)) (not (vector? alist)))
- (el:funcall alist string (or pred '()) '())
+ (%funcall alist (list string (or pred '()) '()))
(%all-completions string alist pred))))
(define (%all-completions string alist pred)
alist
(lambda (eltstring elt)
(if (and (prefix? string eltstring)
- (if pred (not (null? (el:funcall pred elt))) true))
+ (if pred (not (null? (%funcall pred (list elt)))) true))
(set! allmatches (cons eltstring allmatches)))))
(reverse! allmatches)))
(else
(let ((elisp-mode
(%make-mode (string->symbol "anonymous minibuffer mode")
- (list comtab (%global-comtab)))))
+ (list comtab))))
(set-mode-display-name! elisp-mode "emacs minibuffer mode")
(set-mode-major?! elisp-mode true)
(set-mode-description!
(define-key 'minibuffer-local-noblanks #\c-m-y 'minibuffer-yank-default)
(define-key 'minibuffer-local-noblanks #\space 'exit-minibuffer)
(define-key 'minibuffer-local-noblanks #\tab 'exit-minibuffer)
-(define-key 'minibuffer-local-noblanks #\? 'self-insert-and-exit)
\ No newline at end of file
+(define-key 'minibuffer-local-noblanks #\? 'self-insert-and-exit)
+\f
+(DEFUN (el:completion-table-p object)
+ "T if OBJECT is an alist or obarray."
+ (if (completion-table? object) Qt '()))
+
+(define (completion-table? object)
+ (cond ((pair? object)
+ (for-all? object
+ (lambda (entry)
+ (and (pair? entry) (string? (car entry))))))
+ ((vector? object)
+ (for-all-elts? object
+ (lambda (element)
+ (or (%symbol? element) (zero? element)))))
+ (else false)))
+
+(define (for-all-elts? vector predicate)
+ (let ((length (vector-length vector)))
+ (let loop ((index 0))
+ (if (< index length)
+ (let ((element (vector-ref vector index)))
+ (if (predicate element)
+ (loop (1+ index))
+ false))
+ true))))
\ No newline at end of file
The value of the last form in BODY is returned.
If variable `temp-buffer-show-hook' is non-nil, call it at the end
to get the buffer displayed. It gets one argument, the buffer to display."
- (let* ((name (CHECK-STRING (el:eval bufname)))
+ (let* ((name (CHECK-STRING (%eval bufname)))
(buffer (el:get-buffer-create name)))
(%with-output-to-temp-buffer
buffer
- (lambda () (apply el:progn body)))))
+ (lambda () (%progn body)))))
(define (%with-output-to-temp-buffer buffer thunk)
(%with-current-buffer
;;(el:set-window-hscroll window 0)
(set-window-point! window (buffer-start buffer))
(window-scroll-y-absolute! window 0))
- (el:funcall hook buffer))
+ (%funcall hook (list buffer)))
val))))))
(DEFUN (el:terpri #!optional printcharfun)
(if (null? filter)
false
(lambda (string start end)
- (el:funcall filter process
- (if (and (zero? start)
- (= (length string) end))
- string
- (substring string start end)))))))
+ (%funcall filter
+ (list process
+ (if (and (zero? start)
+ (= (length string) end))
+ string
+ (substring string start end))))))))
filter)
(DEFUN (el:process-filter proc)
(if (null? sentinel)
false
(lambda (process emacs-status reason)
- (el:funcall sentinel process
- (process-status-message emacs-status reason))))))
+ (%funcall sentinel
+ (list process
+ (process-status-message emacs-status reason)))))))
sentinel)
(DEFUN (el:process-sentinel proc)
;; This is just an expanded, simplified re-match-forward.
(let ((buffer (%current-buffer))
(string (CHECK-STRING string)))
- (bind-condition-handler
- (list condition-type:re-compile-pattern)
- (lambda (condition)
- (error:%signal Qinvalid-regexp
- (list (access-condition condition 'MESSAGE))))
- (lambda ()
- (if (re-match-forward
- string
- (buffer-point buffer) (buffer-end buffer)
- (not (null? (%symbol-value Qcase-fold-search))))
- Qt
- '())))))
+ (let ((case-fold? (not (null? (%symbol-value Qcase-fold-search))))
+ (group (buffer-group buffer)))
+ (if (re-match-buffer-forward
+ (re-compile-pattern-memoized string case-fold?)
+ case-fold?
+ (group-syntax-table group)
+ group
+ (mark-index (buffer-point buffer))
+ (mark-index (group-end-mark group)))
+ Qt
+ '()))))
(DEFUN (el:string-match regexp string #!optional start)
"Return index of start of first match for REGEXP in STRING, or nil.
start
(error:%signal Qargs-out-of-range
(list string start))))))))
- (bind-condition-handler
- (list condition-type:re-compile-pattern)
- (lambda (condition)
- (error:%signal Qinvalid-regexp
- (list (access-condition condition 'MESSAGE))))
- (lambda ()
- (if (re-match-substring-forward
- (re-compile-pattern regexp fold-case?)
- fold-case? (el:syntax-table)
- string start length)
- Qt
- '()))))))
+ (if (re-search-substring-forward
+ (re-compile-pattern-memoized regexp fold-case?)
+ fold-case?
+ (ref-variable syntax-table (%current-buffer))
+ string start length)
+ (re-match-start-index 0)
+ '()))))
(DEFUN (el:skip-chars-forward string #!optional lim)
"Move point forward, stopping before a char not in CHARS, or at position LIM.
except that ] is never special and \\ quotes ^, - or \\.
Thus, with arg \"a-zA-Z\", this skips letters stopping before first nonletter.
With arg \"^a-zA-Z\", skips nonletters stopping before first letter."
- (let ((buffer (%current-buffer))
- (string (CHECK-STRING string)))
- (let ((limit (if (either-default? lim)
- (buffer-end buffer)
- (let ((min (buffer-start buffer))
- (max (buffer-end buffer))
- (lim (CHECK-MARKER-COERCE-INT lim buffer)))
- (cond ((mark< lim min) min)
- ((mark> lim max) max)
- (else lim))))))
- (bind-condition-handler
- (list condition-type:re-compile-pattern)
- (lambda (condition)
- (error:%signal Qinvalid-regexp
- (list (access-condition condition 'MESSAGE))))
- (lambda ()
- (set-buffer-point! buffer
- (skip-chars-forward string
- (buffer-point buffer)
- limit 'LIMIT)))))))
+ (let* ((string (CHECK-STRING string))
+ (buffer (%current-buffer))
+ (group (buffer-group buffer))
+ (limit (if (either-default? lim)
+ (group-end-mark group)
+ (let ((min (group-start-mark group))
+ (max (group-end-mark group))
+ (lim (CHECK-MARKER-COERCE-INT lim buffer)))
+ (cond ((mark< lim min) min)
+ ((mark> lim max) max)
+ (else lim))))))
+ (set-buffer-point!
+ buffer
+ (let ((index
+ (group-find-next-char-in-set
+ group
+ (mark-index (buffer-point buffer))
+ (mark-index limit)
+ (re-compile-char-set-memoized string))))
+ (if index
+ (make-mark group index)
+ limit)))))
(DEFUN (el:skip-chars-backward string #!optional lim)
"Move point backward, stopping after a char not in CHARS, or at position LIM.
See skip-chars-forward for details."
- (let ((buffer (%current-buffer))
- (string (CHECK-STRING string)))
- (let ((limit (if (either-default? lim)
- (buffer-start buffer)
- (let ((min (buffer-start buffer))
- (max (buffer-end buffer))
- (lim (CHECK-MARKER-COERCE-INT lim buffer)))
- (cond ((mark< lim min) min)
- ((mark> lim max) max)
- (else lim))))))
- (bind-condition-handler
- (list condition-type:re-compile-pattern)
- (lambda (condition)
- (error:%signal Qinvalid-regexp
- (list (access-condition condition 'MESSAGE))))
- (lambda ()
- (set-buffer-point! buffer
- (skip-chars-backward string
- (buffer-point buffer) limit
- 'LIMIT)))))))
+ (let* ((string (CHECK-STRING string))
+ (buffer (%current-buffer))
+ (group (buffer-group buffer))
+ (limit (if (either-default? lim)
+ (group-start-mark group)
+ (let ((min (group-start-mark group))
+ (max (group-end-mark group))
+ (lim (CHECK-MARKER-COERCE-INT lim buffer)))
+ (cond ((mark< lim min) min)
+ ((mark> lim max) max)
+ (else lim))))))
+ (set-buffer-point!
+ buffer
+ (let ((index
+ (group-find-previous-char-in-set
+ group
+ (mark-index limit)
+ (mark-index (buffer-point buffer))
+ (re-compile-char-set-memoized string))))
+ (if index
+ (make-mark group (fix:+ index 1))
+ limit)))))
(DEFUN (el:search-backward string #!optional bound noerror count)
"Search backward from point for STRING.
(point (buffer-point buffer)))
(let ((new-point (search-backward
string point bound
- (not (null? (%symbol-value Qcase-fold-search))))))
+ (ref-variable case-fold-search buffer))))
(cond ((and (not new-point) (null? noerror))
(error:%signal Qsearch-failed (list string)))
((and (not new-point) (eq? noerror Qt))
(point (buffer-point buffer)))
(let ((new-point (search-forward
string point bound
- (not (null? (%symbol-value Qcase-fold-search))))))
+ (ref-variable case-fold-search buffer))))
(cond ((and (not new-point) (null? noerror))
(error:%signal Qsearch-failed (list string)))
((and (not new-point) (eq? noerror Qt))
Optional fourth argument is repeat count--search for successive occurrences.
See also the functions match-beginning and match-end and replace-match."
(interactive "sRE search backward: ")
- (let ((buffer (%current-buffer))
- (string (CHECK-STRING string)))
- (let ((bound (if (either-default? bound)
- (buffer-start buffer)
- (let ((min (buffer-start buffer))
- (max (buffer-point buffer))
- (bnd (CHECK-MARKER-COERCE-INT bound buffer)))
- (cond ((mark< bnd min) min)
- ((mark> bnd max)
- (error:%signal Qerror (list "Invalid search bound (wrong side of point)")))
- (else bnd)))))
- (noerror (if (default-object? noerror) '() noerror)))
- (bind-condition-handler
- (list condition-type:re-compile-pattern)
- (lambda (condition)
- (error:%signal Qinvalid-regexp
- (list (access-condition condition 'MESSAGE))))
- (lambda ()
- (let loop ((count (if (either-default? count)
- 1
- (CHECK-NUMBER count)))
- (point (buffer-point buffer)))
- (let ((new-point
- (re-search-backward
- string point bound
- (not (null? (%symbol-value Qcase-fold-search))))))
- (cond ((and (not new-point) (null? noerror))
- (error:%signal Qsearch-failed (list string)))
- ((and (not new-point) (eq? noerror Qt))
- '())
- ((not new-point)
- (set-buffer-point! buffer bound)
- '())
- ((> count 1)
- (loop (-1+ count) new-point))
- (else
- (set-buffer-point! buffer new-point)
- Qt)))))))))
+ (let* ((string (CHECK-STRING string))
+ (buffer (%current-buffer))
+ (group (buffer-group buffer))
+ (bound (if (either-default? bound)
+ (group-start-index group)
+ (let ((min (buffer-start buffer))
+ (max (buffer-point buffer))
+ (bnd (CHECK-MARKER-COERCE-INT bound buffer)))
+ (cond ((mark< bnd min) (mark-index min))
+ ((mark> bnd max)
+ (error:%signal Qerror (list "Invalid search bound (wrong side of point)")))
+ (else (mark-index bnd))))))
+ (case-fold? (ref-variable case-fold-search buffer))
+ (noerror (if (default-object? noerror) '() noerror)))
+ (let loop ((count (if (either-default? count)
+ 1
+ (CHECK-NUMBER count)))
+ (point (mark-index (buffer-point buffer))))
+ (let ((new-point
+ (re-search-buffer-backward
+ (re-compile-pattern-memoized string case-fold?)
+ case-fold?
+ (group-syntax-table group)
+ group
+ bound
+ point)))
+ (cond ((and (not new-point) (null? noerror))
+ (error:%signal Qsearch-failed (list string)))
+ ((and (not new-point) (eq? noerror Qt))
+ '())
+ ((not new-point)
+ (set-buffer-point! buffer (make-mark group bound))
+ '())
+ ((> count 1)
+ (loop (-1+ count) new-point))
+ (else
+ (set-buffer-point! buffer (make-mark group new-point))
+ Qt))))))
(DEFUN (el:re-search-forward string #!optional bound noerror count)
"Search forward from point for regular expression REGEXP.
Optional fourth argument is repeat count--search for successive occurrences.
See also the functions match-beginning and match-end and replace-match."
(interactive "sRE search: ")
- (let ((buffer (%current-buffer))
- (string (CHECK-STRING string)))
- (let ((bound (if (either-default? bound)
- (buffer-end buffer)
- (let ((min (buffer-point buffer))
- (max (buffer-end buffer))
- (bnd (CHECK-MARKER-COERCE-INT bound buffer)))
- (cond ((mark< bnd min)
- (error:%signal Qerror (list "Invalid search bound (wrong side of point)")))
- ((mark> bnd max) max)
- (else bnd)))))
- (noerror (if (default-object? noerror) '() noerror)))
- (bind-condition-handler
- (list condition-type:re-compile-pattern)
- (lambda (condition)
- (error:%signal Qinvalid-regexp
- (list (access-condition condition 'MESSAGE))))
- (lambda ()
- (let loop ((count (if (either-default? count)
- 1
- (CHECK-NUMBER count)))
- (point (buffer-point buffer)))
- (let ((new-point
- (re-search-forward
- string point bound
- (not (null? (%symbol-value Qcase-fold-search))))))
- (cond ((and (not new-point) (null? noerror))
- (error:%signal Qsearch-failed (list string)))
- ((and (not new-point) (eq? noerror Qt))
- '())
- ((not new-point)
- (set-buffer-point! buffer bound)
- '())
- ((> count 1)
- (loop (-1+ count) new-point))
- (else
- (set-buffer-point! buffer new-point)
- Qt)))))))))
+ (let* ((string (CHECK-STRING string))
+ (buffer (%current-buffer))
+ (group (buffer-group buffer))
+ (bound (if (either-default? bound)
+ (group-end-index group)
+ (let ((min (buffer-point buffer))
+ (max (buffer-end buffer))
+ (bnd (CHECK-MARKER-COERCE-INT bound buffer)))
+ (cond ((mark< bnd min)
+ (error:%signal Qerror (list "Invalid search bound (wrong side of point)")))
+ ((mark> bnd max) (mark-index max))
+ (else (mark-index bnd))))))
+ (case-fold? (ref-variable case-fold-search buffer))
+ (noerror (if (default-object? noerror) '() noerror)))
+ (let loop ((count (if (either-default? count)
+ 1
+ (CHECK-NUMBER count)))
+ (point (mark-index (buffer-point buffer))))
+ (let ((new-point
+ (re-search-buffer-forward
+ (re-compile-pattern-memoized string case-fold?)
+ case-fold?
+ (group-syntax-table group)
+ group
+ point
+ bound)))
+ (cond ((and (not new-point) (null? noerror))
+ (error:%signal Qsearch-failed (list string)))
+ ((and (not new-point) (eq? noerror Qt))
+ '())
+ ((not new-point)
+ (set-buffer-point! buffer (make-mark group bound))
+ '())
+ ((> count 1)
+ (loop (-1+ count) new-point))
+ (else
+ (set-buffer-point! buffer (make-mark group new-point))
+ Qt))))))
(DEFUN (el:replace-match string #!optional fixedcase literal)
"Replace text matched by last search with NEWTEXT.
;; For string-match: punt GNU Emacs' goofy
;; markers/int's. Just use integers!
pos))))
- (let loop ((i 0) (list '()))
+ (let loop ((i 0) (positions '()))
(if (or (= i 10)
(not (re-match-start-index i)))
- (reverse! list)
+ (reverse! positions)
(loop (1+ i)
(cons (->data (re-match-end-index i))
(cons (->data (re-match-start-index i))
- list)))))))
+ positions)))))))
-(DEFUN (el:store-match-data list)
+(DEFUN (el:store-match-data positions)
"Set internal data on last search match from elements of LIST.
LIST should have been created by calling match-data previously."
(vector-fill! registers false)
(let loop ((i 0)
- (list (CHECK-LIST list)))
- (if (and (pair? list)
- (pair? (cdr list)))
- (let ((start (car list))
- (end (car (cdr list))))
+ (positions (CHECK-LIST positions)))
+ (if (and (pair? positions)
+ (pair? (cdr positions)))
+ (let ((start (car positions))
+ (end (car (cdr positions))))
(if (mark? start)
(begin
(vector-set! registers i (mark-index start))
(begin
(vector-set! registers i (CHECK-NUMBER start))
(vector-set! registers i (CHECK-NUMBER end))))
- (loop (1+ i) (cdr (cdr list))))
+ (loop (1+ i) (cdr (cdr positions))))
'())))
(DEFUN (el:regexp-quote str)
"Return a regexp string which matches exactly STRING and nothing else."
- (re-quote-string (CHECK-STRING str)))
\ No newline at end of file
+ (re-quote-string (CHECK-STRING str)))
+\f
+(define saved-regexp-string1 "")
+(define saved-regexp-string2 "")
+(define saved-regexp-string3 "")
+(define saved-fold-case1? false)
+(define saved-fold-case2? false)
+(define saved-fold-case3? false)
+(define saved-regexp1 "")
+(define saved-regexp2 "")
+(define saved-regexp3 "")
+
+(define (re-compile-pattern-memoized regexp-string fold-case?)
+ ;; Can string-ci=? be used when {saved-}fold-case? match and are true?
+ (if (and (string=? regexp-string saved-regexp-string1)
+ (eq? fold-case? saved-fold-case1?))
+ saved-regexp1
+ (if (and (string=? regexp-string saved-regexp-string2)
+ (eq? fold-case? saved-fold-case2?))
+ saved-regexp2
+ (if (and (string=? regexp-string saved-regexp-string3)
+ (eq? fold-case? saved-fold-case3?))
+ saved-regexp3
+ (let ((regexp
+ (bind-condition-handler
+ (list condition-type:re-compile-pattern)
+ (lambda (condition)
+ (error:%signal
+ Qinvalid-regexp
+ (list (access-condition condition 'MESSAGE))))
+ (lambda ()
+ (re-compile-pattern regexp-string fold-case?)))))
+ (set! saved-regexp-string3 saved-regexp-string2)
+ (set! saved-fold-case3? saved-fold-case2?)
+ (set! saved-regexp3 saved-regexp2)
+ (set! saved-regexp-string2 saved-regexp-string1)
+ (set! saved-fold-case2? saved-fold-case1?)
+ (set! saved-regexp2 saved-regexp1)
+ (set! saved-regexp-string1 regexp-string)
+ (set! saved-fold-case1? fold-case?)
+ (set! saved-regexp1 regexp)
+ regexp)))))
+\f
+(define saved-char-set-string1 "")
+(define saved-char-set-string2 "")
+(define saved-char-set-string3 "")
+(define saved-char-set1 "")
+(define saved-char-set2 "")
+(define saved-char-set3 "")
+
+(define (re-compile-char-set-memoized char-set-string)
+ (if (string=? char-set-string saved-char-set-string1)
+ saved-char-set1
+ (if (string=? char-set-string saved-char-set-string2)
+ saved-char-set2
+ (if (string=? char-set-string saved-char-set-string3)
+ saved-char-set3
+ (let ((char-set
+ (bind-condition-handler
+ (list condition-type:re-compile-pattern)
+ (lambda (condition)
+ (error:%signal
+ Qinvalid-regexp
+ (list (access-condition condition 'MESSAGE))))
+ (lambda ()
+ (re-compile-char-set char-set-string true)))))
+ (set! saved-char-set-string3 saved-char-set-string2)
+ (set! saved-char-set3 saved-char-set2)
+ (set! saved-char-set-string2 saved-char-set-string1)
+ (set! saved-char-set2 saved-char-set1)
+ (set! saved-char-set-string1 char-set-string)
+ (set! saved-char-set1 char-set)
+ char-set)))))
\ No newline at end of file
before each command."
(let ((window (CHECK-WINDOW window)))
(cond ((not (window-buffer window))
- (el:signal Qerror (list "Trying to select window with no buffer")))
+ (error:%signal Qerror
+ (list "Trying to select window with no buffer")))
((current-window? window) window)
(else
(select-window window)
(CHECK-WINDOW window)))
(horizontal? (not (either-default? horflag))))
(if (typein-window? window)
- (el:signal Qerror (list "Attempt to split minibuffer window")))
+ (error:%signal Qerror (list "Attempt to split minibuffer window")))
(let ((chsize (if (either-default? chsize)
(/ (if horizontal?
(1+ (window-x-size window))
(if side?
(if (window-has-horizontal-neighbor? window)
(window-grow-horizontally! (current-window) n)
- (el:signal Qerror
- (list "No other window to side of this one")))
+ (error:%signal Qerror
+ (list "No other window to side of this one")))
(if (window-has-vertical-neighbor? window)
(window-grow-vertically! (current-window) n)
- (el:signal Qerror
- (list "No other window to side of this one"))))))
+ (error:%signal
+ Qerror (list "No other window to side of this one"))))))
'())
(DEFUN (el:shrink-window n #!optional side)
(window (current-window)))
(scroll-window window
(standard-scroll-window-argument window n 1)
- (lambda () (el:signal Qend-of-buffer '()))))
+ (lambda () (error:%signal Qend-of-buffer '()))))
'())
(DEFUN (el:scroll-down #!optional n)
(window (current-window)))
(scroll-window window
(standard-scroll-window-argument window n -1)
- (lambda () (el:signal Qbeginning-of-buffer '()))))
+ (lambda () (error:%signal Qbeginning-of-buffer '()))))
'())
#|(DEFUN (el:scroll-left arg)
as well as the current buffer.
Does not restore the value of point in current buffer."
(%save-window-excursion
- (lambda () (apply el:progn args))))
+ (lambda () (%progn args))))
(define (%save-window-excursion thunk)
(let ((screen (selected-screen)))
projects / mit-scheme.git / commitdiff