From: Matt Birkholz Date: Tue, 18 Jan 2011 18:35:52 +0000 (-0700) Subject: Used define-structure; added integration declarations. X-Git-Tag: 20110609-ELisp~5 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=14f95b5f6f9fada278b3ddb8d8d8e12a099fad59;p=mit-scheme.git Used define-structure; added integration declarations. Other performance enhancements: memoize regexp compilation, avoid unnecessary use of apply and subrs. --- diff --git a/src/elisp/Subrs.scm b/src/elisp/Subrs.scm index 96a70da85..92c23966a 100644 --- a/src/elisp/Subrs.scm +++ b/src/elisp/Subrs.scm @@ -13,43 +13,38 @@ Lisp. |# (declare (usual-integrations)) -(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 diff --git a/src/elisp/Symbols.scm b/src/elisp/Symbols.scm index 53924a636..7e73524ff 100644 --- a/src/elisp/Symbols.scm +++ b/src/elisp/Symbols.scm @@ -41,120 +41,76 @@ Emacs symbol. |# (declare (usual-integrations)) -(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 '() '() + '() '() '() '() '() '() '())) ;;;; 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) @@ -169,30 +125,31 @@ Emacs symbol. |# '() 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) @@ -225,10 +182,10 @@ Emacs symbol. |# (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) diff --git a/src/elisp/abbrev.scm b/src/elisp/abbrev.scm index cb9e862bf..e8ee1a24e 100644 --- a/src/elisp/abbrev.scm +++ b/src/elisp/abbrev.scm @@ -144,13 +144,13 @@ of the form (ABBREVNAME EXPANSION HOOK USECOUNT)." 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))))))) '()) (DEFVAR Qabbrev-table-name-list diff --git a/src/elisp/alloc.scm b/src/elisp/alloc.scm index 878d917cb..fc540fe94 100644 --- a/src/elisp/alloc.scm +++ b/src/elisp/alloc.scm @@ -14,7 +14,7 @@ Storage allocation and gc for GNU Emacs Lisp interpreter. |# (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." diff --git a/src/elisp/bytecode.scm b/src/elisp/bytecode.scm index fa7dd402c..6d34abc89 100644 --- a/src/elisp/bytecode.scm +++ b/src/elisp/bytecode.scm @@ -269,9 +269,9 @@ Execution of byte code produced by bytecomp.el. |# (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 @@ -343,7 +343,7 @@ Execution of byte code produced by bytecomp.el. |# op (CONTINUE (%save-window-excursion - (lambda () (PUSH (apply el:progn (POP))))))) + (lambda () (PUSH (%progn (POP))))))) (define (DOsave_restriction op) op @@ -356,18 +356,18 @@ Execution of byte code produced by bytecomp.el. |# (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 @@ -398,9 +398,9 @@ Execution of byte code produced by bytecomp.el. |# (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 @@ -433,8 +433,8 @@ Execution of byte code produced by bytecomp.el. |# (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 @@ -444,12 +444,12 @@ Execution of byte code produced by bytecomp.el. |# (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 diff --git a/src/elisp/callint.scm b/src/elisp/callint.scm index 7f9327404..3de35173f 100644 --- a/src/elisp/callint.scm +++ b/src/elisp/callint.scm @@ -129,7 +129,7 @@ See `interactive'. 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?) @@ -145,7 +145,7 @@ Otherwise, this is done only if an arg is read using the minibuffer." 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 @@ -218,7 +218,7 @@ Otherwise, this is done only if an arg is read using the minibuffer." '()) (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")) @@ -301,7 +301,7 @@ in the command-history as though this command had been called." (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. diff --git a/src/elisp/data.scm b/src/elisp/data.scm index e9e00c018..5d9e676c6 100644 --- a/src/elisp/data.scm +++ b/src/elisp/data.scm @@ -82,7 +82,7 @@ Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. |# (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))) @@ -126,7 +126,6 @@ Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. |# ((%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 '())) @@ -169,21 +168,27 @@ Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. |# ;;; 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." @@ -286,7 +291,7 @@ for this variable." "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. diff --git a/src/elisp/editfns.scm b/src/elisp/editfns.scm index 49bd71e44..9fa98255c 100644 --- a/src/elisp/editfns.scm +++ b/src/elisp/editfns.scm @@ -62,7 +62,7 @@ The marker will not point anywhere if mark is not set." "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)))) (DEFUN (el:buffer-size) "Return the number of characters in the current buffer." @@ -347,7 +347,7 @@ and then make changes outside the area within the saved restrictions. 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! diff --git a/src/elisp/elisp.pkg b/src/elisp/elisp.pkg index 4c7c58520..0972446a5 100644 --- a/src/elisp/elisp.pkg +++ b/src/elisp/elisp.pkg @@ -77,6 +77,7 @@ Copyright (c) 1993 Matthew Birkholz, All Rights Reserved |# (files "Subrs") (parent (elisp)) (export (elisp) + %subr ;record type, used by inlined %subr? %subr? %make-subr %subr-docstring @@ -89,6 +90,8 @@ Copyright (c) 1993 Matthew Birkholz, All Rights Reserved |# (files "Symbols") (parent (elisp)) (export (elisp) + %symbol ;record type, used by inlined %symbol? + +unbound+ ;constant, used by %symbol-fbound?... %symbol? %make-symbol %symbol-name @@ -115,6 +118,7 @@ Copyright (c) 1993 Matthew Birkholz, All Rights Reserved |# %intern %intern-soft %for-symbol + %make-symbol-global! ;procedure, used by %make-symbol %make-symbol-variable! %make-symbol-generic! boolean-getter @@ -136,6 +140,7 @@ Copyright (c) 1993 Matthew Birkholz, All Rights Reserved |# (files "Buffers") (parent (elisp)) (export (elisp) + elisp-current-buffer ;variable, used by %current-buffer... %with-current-buffer %current-buffer %set-current-buffer! diff --git a/src/elisp/elisp.sf b/src/elisp/elisp.sf index 04cc7a252..cd0eec7fd 100644 --- a/src/elisp/elisp.sf +++ b/src/elisp/elisp.sf @@ -37,18 +37,35 @@ Copyright (c) 1993 Matthew Birkholz, All Rights Reserved |# (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 diff --git a/src/elisp/eval.scm b/src/elisp/eval.scm index bc80cb8a8..3541fae36 100644 --- a/src/elisp/eval.scm +++ b/src/elisp/eval.scm @@ -34,14 +34,46 @@ be compatible with this behavior. |# (list Qwrong-number-of-arguments Qerror)) (%put! Qwrong-number-of-arguments Qerror-message "Wrong number of arguments") +;;;; 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))))))) + +;;;; 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. @@ -49,7 +81,7 @@ The remaining args are not evalled at all. 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) '() @@ -62,10 +94,10 @@ If no arg yields NIL, return the last arg's 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. @@ -81,22 +113,16 @@ If no clause succeeds, cond returns nil." (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. @@ -104,8 +130,8 @@ This value is saved during the evaluation of the remaining args, 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) @@ -115,30 +141,31 @@ whose values are discarded." (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." @@ -220,7 +247,7 @@ If INITVALUE is missing, SYMBOL's value is not set." (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)) @@ -236,7 +263,7 @@ If DOCSTRING starts with *, this variable is identified as a user option. (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) @@ -255,11 +282,11 @@ Each element of VARLIST is a symbol (which is bound to NIL) 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. @@ -269,69 +296,63 @@ or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). 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. @@ -339,6 +360,9 @@ If the result of expansion is another macro call, expand it, etc. 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))) @@ -347,7 +371,7 @@ definitions to shadow the loaded ones for use in file byte-compilation." (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)))))) @@ -356,18 +380,17 @@ definitions to shadow the loaded ones for use in file byte-compilation." 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 @@ -386,7 +409,7 @@ TAG is evalled to get the tag to use. throw to that tag exits this catch. 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 @@ -410,8 +433,8 @@ If BODYFORM completes normally, its value is returned 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 @@ -471,18 +494,17 @@ See SIGNAL for more info." (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. @@ -527,9 +549,9 @@ Also, a symbol is commandp if its function definition is commandp." (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_) @@ -618,6 +640,10 @@ this does nothing and returns nil." (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)) @@ -629,15 +655,15 @@ this does nothing and returns nil." (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))) @@ -648,20 +674,22 @@ this does nothing and returns nil." "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)))) @@ -687,7 +715,7 @@ Thus, (funcall 'cons 'x 'y) returns (x . y)." (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)) () @@ -763,17 +791,4 @@ Thus, (funcall 'cons 'x 'y) returns (x . y)." (if (string? (car body)) (car body) false))) - (else false)))) - -;;;; 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 diff --git a/src/elisp/fileio.scm b/src/elisp/fileio.scm index 805cca2d3..f0b13f44f 100644 --- a/src/elisp/fileio.scm +++ b/src/elisp/fileio.scm @@ -22,10 +22,10 @@ Note: filename operations only work for UN*X. |# 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.")|# (DEFUN (el:file-name-directory file) "Return the directory component in file name NAME. @@ -787,20 +787,20 @@ DIR defaults to current buffer's directory default." (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) diff --git a/src/elisp/fns.scm b/src/elisp/fns.scm index 66a0b8f09..b0cc8c4a4 100644 --- a/src/elisp/fns.scm +++ b/src/elisp/fns.scm @@ -188,20 +188,20 @@ If FROM or TO is negative, it counts from the end." (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." @@ -212,18 +212,18 @@ N counts from zero. If LIST is not that long, nil is returned." (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))) @@ -232,10 +232,10 @@ The value is actually the element of LIST whose car is ELT." 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))) @@ -244,10 +244,10 @@ The value is actually the element of LIST whose car is ELT." 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))) @@ -256,42 +256,42 @@ The value is actually the element of LIST whose cdr is ELT." 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 @@ -300,7 +300,7 @@ if the first element is \"less\" than the second." ;; 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) @@ -308,13 +308,13 @@ if the first element is \"less\" than the second." (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. @@ -369,24 +369,24 @@ Thus, \" \" as SEP results in spaces between the values return by FN." (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) diff --git a/src/elisp/lisp.scm b/src/elisp/lisp.scm index fb1c1194c..4948de58e 100644 --- a/src/elisp/lisp.scm +++ b/src/elisp/lisp.scm @@ -64,6 +64,7 @@ Fundamental definitions for GNU Emacs Lisp interpreter. |# 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) @@ -74,12 +75,11 @@ Fundamental definitions for GNU Emacs Lisp interpreter. |# 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) @@ -103,7 +103,7 @@ Fundamental definitions for GNU Emacs Lisp interpreter. |# 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)) @@ -116,15 +116,16 @@ Fundamental definitions for GNU Emacs Lisp interpreter. |# ((> 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)) @@ -132,15 +133,14 @@ Fundamental definitions for GNU Emacs Lisp interpreter. |# (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)) @@ -164,31 +164,6 @@ Fundamental definitions for GNU Emacs Lisp interpreter. |# 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))) diff --git a/src/elisp/lread.scm b/src/elisp/lread.scm index f48485bfe..e3af30a7d 100644 --- a/src/elisp/lread.scm +++ b/src/elisp/lread.scm @@ -44,7 +44,7 @@ otherwise to default specified in init-load-path of lread.scm.") (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)) @@ -116,14 +116,14 @@ See documentation of read for possible values.") (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)))) @@ -192,7 +192,7 @@ Return t if file exists." (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")) @@ -212,7 +212,7 @@ nil means discard it; anything else is stream for print." (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) @@ -236,7 +236,7 @@ nil means discard it; anything else is stream for print." (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)))))) @@ -296,7 +296,7 @@ A second optional argument specifies the obarray to use; 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))) @@ -306,7 +306,7 @@ A second optional argument specifies the obarray to use; 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))) @@ -314,7 +314,7 @@ it defaults to the value of obarray." "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 diff --git a/src/elisp/minibuf.scm b/src/elisp/minibuf.scm index 492f35993..fdc507a0a 100644 --- a/src/elisp/minibuf.scm +++ b/src/elisp/minibuf.scm @@ -72,9 +72,9 @@ is a string to insert in the minibuffer before reading." "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. @@ -137,7 +137,7 @@ The argument given to PREDICATE is the alist element or the symbol from the obar (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 '()) @@ -171,7 +171,7 @@ The argument given to PREDICATE is the alist element or the symbol from the obar 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) @@ -200,7 +200,7 @@ The argument given to PREDICATE is the alist element or the symbol from the obar (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) @@ -209,7 +209,7 @@ The argument given to PREDICATE is the alist element or the symbol from the obar 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))) @@ -401,7 +401,7 @@ NOTE: help-form is not supported by Edwin.") (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! @@ -425,4 +425,29 @@ The following commands are special to this mode: (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) + +(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 diff --git a/src/elisp/print.scm b/src/elisp/print.scm index a30588ea6..4ba0d277b 100644 --- a/src/elisp/print.scm +++ b/src/elisp/print.scm @@ -25,11 +25,11 @@ It is displayed in another window, but not selected. 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 @@ -49,7 +49,7 @@ to get the buffer displayed. It gets one argument, the buffer to display." ;;(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) diff --git a/src/elisp/process.scm b/src/elisp/process.scm index 9d498ddc2..c719e3894 100644 --- a/src/elisp/process.scm +++ b/src/elisp/process.scm @@ -178,11 +178,12 @@ If the process has a filter, its buffer is not used for output." (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) @@ -204,8 +205,9 @@ It gets two arguments: the process, and a string describing the change." (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) diff --git a/src/elisp/search.scm b/src/elisp/search.scm index 70d39d3e2..c8eb1a4ac 100644 --- a/src/elisp/search.scm +++ b/src/elisp/search.scm @@ -21,18 +21,17 @@ String search routines for GNU Emacs. |# ;; 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. @@ -57,18 +56,13 @@ matched by parenthesis constructs in the pattern." 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. @@ -76,50 +70,54 @@ CHARS is like the inside of a [...] in a regular expression 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. @@ -148,7 +146,7 @@ Optional fourth argument is repeat count--search for successive occurrences." (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)) @@ -189,7 +187,7 @@ Optional fourth argument is repeat count--search for successive occurrences." (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)) @@ -245,44 +243,44 @@ Optional third argument, if t, means if fail just return nil (no error). 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. @@ -294,44 +292,44 @@ Optional third argument, if t, means if fail just return nil (no error). 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. @@ -401,25 +399,25 @@ if a match began at index 0 in the string." ;; 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)) @@ -427,9 +425,81 @@ LIST should have been created by calling match-data previously." (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))) + +(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))))) + +(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 diff --git a/src/elisp/window.scm b/src/elisp/window.scm index 4414d21cc..138793950 100644 --- a/src/elisp/window.scm +++ b/src/elisp/window.scm @@ -261,7 +261,8 @@ The main editor command loop selects the buffer of the selected window 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) @@ -291,7 +292,7 @@ and put SIZE columns in the first of the pair." (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)) @@ -318,12 +319,12 @@ From program, optional second arg non-nil means grow sideways ARG columns." (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) @@ -347,7 +348,7 @@ When calling from a program, supply a number as argument or nil." (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) @@ -360,7 +361,7 @@ When calling from a program, supply a number as argument or nil." (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) @@ -428,7 +429,7 @@ Restores which buffer appears in which window, where display starts, 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)))