# **** END BOILERPLATE ****
LIARC_BOOT_BUNDLES = compiler cref sf star-parser
-LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml
+LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin elisp ffi imail sos ssp xml
SUBDIRS = $(INSTALLED_SUBDIRS) 6001 compiler rcs win32 xdoc
INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES)
version of this code that is no longer in use (and probably no
longer works).
+* "elisp" contains a GNU Emacs emulator for Edwin.
+
* "etc" contains miscellaneous files for building the program.
* "rcs" is a parser for RCS files. It also contains a program for
. etc/functions.sh
-INSTALLED_SUBDIRS="cref edwin ffi imail sf sos ssp star-parser xml"
+INSTALLED_SUBDIRS="cref edwin elisp ffi imail sf sos ssp star-parser xml"
OTHER_SUBDIRS="6001 compiler rcs runtime win32 xdoc microcode"
# lib
maybe_link lib/runtime ../runtime
maybe_link lib/mit-scheme.h ../microcode/pruxffi.h
maybe_link lib/ffi ../ffi
+maybe_link lib/elisp ../elisp
for SUBDIR in ${INSTALLED_SUBDIRS} ${OTHER_SUBDIRS}; do
echo "setting up ${SUBDIR}"
rcs/TAGS,include
\f
ffi/TAGS,include
+\f
+elisp/TAGS,include
(define compile-file)
(let ((scm-pathname (lambda (path) (pathname-new-type path "scm")))
(bin-pathname (lambda (path) (pathname-new-type path "bin")))
- (ext-pathname (lambda (path) (pathname-new-type path "ext")))
+ (ext-pathname (lambda (path) (pathname-default-type path "ext")))
+ (ext-pathname? (lambda (path) (string=? "ext" (pathname-type path))))
(com-pathname
(lambda (path)
(pathname-new-type path (compiler:compiled-code-pathname-type)))))
,@compile-file:override-usual-integrations)
,@(if (null? dependencies)
'()
- `((INTEGRATE-EXTERNAL ,@dependencies))))))
+ `((INTEGRATE-EXTERNAL
+ ,@(filter ext-pathname?
+ dependencies)))))))
(sf input-file output-file))))
(if (not compile-file:sf-only?)
(process-file (bin-pathname file)
(com-pathname file)
'()
(lambda (input-file output-file dependencies)
- dependencies
+ (declare (ignore dependencies))
(fluid-let ((compiler:coalescing-constant-warnings? #f))
(compile-bin-file input-file output-file))))))))
+
+(define (compile-files files package-name dependencies)
+ (let ((env (->environment package-name))
+ (deps (map (lambda (path) (pathname-default-type path "ext"))
+ dependencies)))
+ (for-each (lambda (file) (compile-file file deps env)) files)))
\f
;;;; Non-Incremental File Compiler
cf
compile-bin-file
compile-file
+ compile-files
compile-file:force?
compile-file:override-usual-integrations
compile-file:sf-only?
cf
compile-bin-file
compile-file
+ compile-files
compile-file:force?
compile-file:override-usual-integrations
compile-file:sf-only?
cf
compile-bin-file
compile-file
+ compile-files
compile-file:force?
compile-file:override-usual-integrations
compile-file:sf-only?
cf
compile-bin-file
compile-file
+ compile-files
compile-file:force?
compile-file:override-usual-integrations
compile-file:sf-only?
cf
compile-bin-file
compile-file
+ compile-files
compile-file:force?
compile-file:override-usual-integrations
compile-file:sf-only?
compiler/Makefile
cref/Makefile
edwin/Makefile
+elisp/Makefile
ffi/Makefile
imail/Makefile
runtime/Makefile
for BN in star-parser; do
(cd lib; rm -f ${BN}; ${LN_S} ../${BN} .)
done
- for BUNDLE in 6001 compiler cref edwin ffi imail sf sos ssp star-parser \
- xdoc xml; do
+ for BUNDLE in 6001 compiler cref edwin elisp ffi imail sf sos ssp \
+ star-parser xdoc xml; do
SO=${BUNDLE}.so
(cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .)
done
;;;; Scheme Syntax Extensions
;;; package: (elisp syntax-extensions)
-\f
-(define elisp-syntax-table (make-syntax-table edwin-syntax-table))
-(syntax-table-define elisp-syntax-table 'DEFUN
- (macro (lambda-list . body)
- (let* ((Fsym
- (if (not (pair? lambda-list))
- (error "First arg to DEFUN must be a pair whose car is the Emacs Lisp primitive's name.")
- (let ((name (car lambda-list)))
- (set! lambda-list (cdr lambda-list))
- name)))
- (name
- (if (string-prefix? "el:" (symbol->string Fsym))
- (string-tail (symbol->string Fsym) 3)
- (error "Emacs Lisp primitive names should be prefixed by \"el:\"")))
- (Ssym
- (intern (string-append "Q" name)))
- (docstring
- (if (and (pair? body)
- (string? (car body)))
- (let ((docstring (car body)))
- (set! body (cdr body))
- docstring)
- false))
- (prompt
- (if (and (pair? body)
- (pair? (car body))
- (eq? 'INTERACTIVE (caar body)))
- (let ((prompt (cond ((null? (cdar body)) "")
- ((and (pair? (cdar body))
- (string? (cadar body)))
- (cadar body))
- (else
- (error "Interactive prompt not a string!"
- "DEFUN" (symbol->string Fsym))))))
- (set! body (cdr body))
- prompt)
- false))
- (special-form?
- (if (and (pair? lambda-list)
- (eq? (car lambda-list) '"e))
- (begin
- (set! lambda-list (cdr lambda-list))
- true)
- false)))
- `(begin
- (define ,Ssym (%intern ,name initial-obarray))
- (define ,Fsym (%make-subr
- ,(symbol->string Fsym)
- (named-lambda
- (,Fsym . ,lambda-list)
- . ,body)
- ,docstring
- ,prompt
- ,special-form?))
- (%set-symbol-function! ,Ssym ,Fsym)
- unspecific))))
+;;; These syntactic extensions help Scheme code define Emacs functions
+;;; and variables, and deal with optional arguments.
+\f
+(define-syntax DEFUN
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (declare (ignore usage-env))
+ (let* ((lambda-list (cadr form))
+ (body (cddr form))
+ (Fsym
+ (if (not (pair? lambda-list))
+ (error "First arg to DEFUN must be a pair whose car is the Emacs Lisp primitive's name.")
+ (let ((name (car lambda-list)))
+ (set! lambda-list (cdr lambda-list))
+ name)))
+ (name
+ (if (string-prefix? "el:" (symbol->string Fsym))
+ (string-tail (symbol->string Fsym) 3)
+ (error "Emacs Lisp primitive names should be prefixed by \"el:\"")))
+ (Ssym
+ (intern (string-append "Q" name)))
+ (docstring
+ (if (and (pair? body)
+ (string? (car body)))
+ (let ((docstring (car body)))
+ (set! body (cdr body))
+ docstring)
+ '()))
+ (prompt
+ (if (and (pair? body)
+ (pair? (car body))
+ (eq? 'INTERACTIVE (caar body)))
+ (let ((prompt (cond ((null? (cdar body)) "")
+ ((and (pair? (cdar body))
+ (string? (cadar body)))
+ (cadar body))
+ (else
+ (error "Interactive prompt not a string!"
+ "DEFUN" (symbol->string Fsym))))))
+ (set! body (cdr body))
+ prompt)
+ '()))
+ (special-form?
+ (if (and (pair? lambda-list)
+ (eq? (car lambda-list) '"e))
+ (begin
+ (set! lambda-list (cdr lambda-list))
+ true)
+ false)))
+ `(BEGIN
+ (DEFINE ,Ssym (%INTERN ,name INITIAL-OBARRAY))
+ (DEFINE ,Fsym (%MAKE-SUBR
+ ,(symbol->string Fsym)
+ (NAMED-LAMBDA
+ (,Fsym . ,lambda-list)
+ . ,body)
+ ,docstring
+ ,prompt
+ ,special-form?))
+ (%SET-SYMBOL-FUNCTION! ,Ssym ,Fsym)
+ unspecific)))))
-(syntax-table-define elisp-syntax-table 'DEFVAR
- (macro (Ssym #!optional init docstring getter setter)
- (let ((name
- (if (string-prefix? "q" (symbol->string Ssym))
- (string-tail (symbol->string Ssym) 1)
- (error "Emacs Lisp symbol names should be prefixed by \"Q\""))))
- `(begin
- (define ,Ssym (%intern ,name initial-obarray))
- ,@(cond ((and (not (default-object? getter))
- (not (default-object? setter)))
- `((%make-symbol-generic! ,Ssym ,getter ,setter)))
- ((not (default-object? getter))
+(define-syntax DEFVAR
+ (sc-macro-transformer
+ (lambda (form usage-env)
+ (declare (ignore usage-env))
+ (let* ((Ssym (list-ref form 1))
+ (init (list-ref form 2))
+ (docstring (list-ref form 3))
+ (getter (list-ref-or-not form 4))
+ (setter (list-ref-or-not form 5))
+ (name
+ (if (string-prefix? "q" (symbol->string Ssym))
+ (string-tail (symbol->string Ssym) 1)
+ (error "Emacs Lisp symbol names should be prefixed by \"Q\""))))
+ `(BEGIN
+ (DEFINE ,Ssym (%INTERN ,name INITIAL-OBARRAY))
+ ;; Init the value (if any), for the editor variable default.
+ ,@(if (or (default-object? init) (eq? init 'unassigned))
+ '()
+ `((%INIT-SYMBOL-VALUE! ,Ssym ,init)))
+ ,@(cond ((and getter setter)
+ `((%MAKE-SYMBOL-GENERIC! ,Ssym ,getter ,setter)))
+ (getter
(error "No set-value! method provided for generic DEFVAR."))
(else
- `((%make-symbol-variable! ,Ssym))))
+ `((%MAKE-SYMBOL-VARIABLE! ,Ssym))))
,@(if (default-object? docstring)
'()
- `((%put! ,Ssym Qvariable-documentation ,docstring)))
- ,@(if (or (default-object? init) (eq? init 'unassigned))
- '()
- `((%set-symbol-value! ,Ssym ,init)))
- unspecific))))
-
-;;; Since default-object? is a macro expanding into
-;;; (lexical-unassigned? (the-environment) 'name), either-default? must also
-;;; be a macro expanding into a test of 'name in the same environment.
-
-(syntax-table-define elisp-syntax-table 'EITHER-DEFAULT?
- (macro (name)
- `(or (default-object? ,name)
- (null? ,name))))
-
-;;; Steal this from runtime/sysmac.scm.
+ `((%PUT! ,Ssym QVARIABLE-DOCUMENTATION ,docstring))))))))
-(syntax-table-define elisp-syntax-table 'UCODE-PRIMITIVE
- (macro arguments
- (apply make-primitive-procedure arguments)))
\ No newline at end of file
+(define (list-ref-or-not form index)
+ (let ((l (length form)))
+ (if (< index l)
+ (list-ref form index)
+ #f)))
\ No newline at end of file
--- /dev/null
+#-*-Makefile-*-
+# elisp/Makefile-fragment
+
+TARGET_DIR = $(AUXDIR)/elisp
+
+install:
+ rm -rf $(DESTDIR)$(TARGET_DIR)
+ $(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
+ $(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) elisp-*.pkd $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) $(srcdir)/load.scm $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) $(srcdir)/load-up.el $(DESTDIR)$(TARGET_DIR)/.
"Read and evaluate an Emacs Lisp expression in the typein window."
"sEvaluate ELisp expression"
(lambda (input-string)
+ (autoload-essential-elisp)
(with-input-from-string ""
(lambda ()
(let ((value))
"Read an Emacs Lisp command from the terminal with completion and
invoke it."
(lambda ()
+ (autoload-essential-elisp)
(list (el:read-command "el:M-x ")))
(lambda (command)
+ (autoload-essential-elisp)
(%call-interactively (current-buffer) command true)))
+(define essential-elisp-loaded? #f)
-;;;;
+(define (autoload-essential-elisp)
+ ;; For use in Edwin commands that invoke Emacs Lisp modes or
+ ;; whatnot. This should be evaled in the editor thread.
+ (if (not essential-elisp-loaded?)
+ (begin
+ (load-essential-elisp)
+ (set! essential-elisp-loaded? #t))))
-(define (load-essential-elisp #!optional load-path)
- (let ((load-path (if (default-object? load-path)
- '("~birkholz/Thesis/src/elisp")
- load-path)))
- (%set-symbol-value! Qload-path load-path))
- ;; Don't let load-up.el leave elisp-current-buffer assigned to a
- ;; random buffer. Nobody should care, except maybe someone
- ;; expecting the random buffer to be garbage collected.
+(define (load-essential-elisp)
(%with-current-buffer
(current-buffer)
(lambda ()
- (fluid-let ((allow-elisp-define-key-overrides? false))
- (el:load "load-up")))))
\ No newline at end of file
+ (let ((path (system-library-pathname "elisp/load-up.el")))
+ (if (not (file-exists? path)) (error "File not found:" path))
+ (fluid-let ((allow-elisp-define-key-overrides? false))
+ (el:load (->namestring path)))))))
\ No newline at end of file
--- /dev/null
+-*-Text-*-
+
+
+Emacs Lisp Emulator
+===================
+
+Some notes on the Emacs Lisp emulator.
+
+
+Organization of Files and Bindings
+----------------------------------
+
+The capitalized files (e.g. Symbols.scm) implement the emulator's data
+types and utilities. They are loaded into their own packages and
+export bindings to the (elisp) package. The exported bindings are
+prefixed with "%", e.g. %symbol-value.
+
+The lowercase files correspond to those in Emacs's src/ subdirectory.
+They are loaded into the (elisp) package and use the %internal
+bindings to implement the DEFUNs and DEFVARs in each C file. The
+Macros.scm file provides convenient DEFUN and DEFVAR syntaxes for this
+purpose. Both produce a binding whose name is prefixed with "Q" whose
+value is an Emacs Lisp %symbol (following the naming convention in the
+C code). E.g. "Qsetq" is bound to the Emacs Lisp symbol "setq". The
+DEFUN syntax also produces a procedural binding prefixed with "el:".
+E.g. "el:setq" is bound to the procedure implementing Emacs Lisp's
+setq primitive. The Qsetq symbol's function value is set to this
+Scheme procedure.
+
+
+The Interpreter
+---------------
+
+The Emacs Lisp reader produces lists of %symbols, strings, vectors,
+characters, etc. Most of these types are identical to a Scheme data
+type: Emacs Lisp strings are Scheme strings, Emacs Lisp vectors are
+Scheme vectors, and so on. %Symbols, however, are NOT Scheme symbols;
+they are structures containing a value, function, property list, and a
+method for each symbol operation (e.g. get-value). These methods are
+changed when a symbol becomes buffer-local, e.g. so that they get the
+value of the corresponding Edwin editor variable, rather than of its
+value slot.
+
+Emacs Lisp's symbol "nil" is both its false value and its empty list.
+Version 9 of MIT/GNU Scheme uses distinct values #f and (). In this
+emulator, nil has been identified with () (to maximize the speed of
+el:cdr?). Thus Scheme code that wishes to use an Emacs Lisp predicate
+must test its value.
+
+ (cond ((not-nil? (el:assq key sumpn-table)) => dispatch)
+ (else (error "Bad key:" key)))
+
+The only Emacs Lisp file in this distribution is load-up.el, a pared
+down version of Emacs23's loadup.el. You will want to edit its
+definition of load-path to include your copy of Emacs23's lisp source
+code.
+
+
+How To Run
+----------
+
+ (load-option 'ELISP)
+ (edit)
+ M-x execute-extended-elisp-command
+ <error>
+
+
+TODO
+----
+
+The emulator was written in the days of Emacs version 18.58, and needs
+quite a bit of updating. lread.scm and Reader.scm are probably the
+places to start. Until el:read (parse-elisp-object) is updated to
+handle backquotes, boolean vectors, unicode characters(?), etc., etc.,
+load-up.el will not get far.
+
+A tight focus, like the calendar/diary modes, might carve out a small
+piece of the Emacs23 API and produce a useful Edwin mode. That was
+the original strategy -- to focus on the news reader GNUS.
+Unfortunately, there is no Usenet in this cloister, and the Abbess
+does not accept requisitions for alt.binaries. :-)
+
+There is no reason Emacs Lisp symbols cannot be Scheme symbols.
+Things like function values or property lists can be stored in hash
+tables, indexed by the Scheme symbol. The symbol value could be
+stored in a binding in (elisp), and Emacs's dynamic scoping reserved
+for special cases (e.g. standard-input). A survey of the codebase
+would help to estimate how much of Emacs23's code can be trivially
+transformed (compiled!) into equivalent Scheme. The survey might
+produce a list of the symbols (per package?) whose references must be
+compiled into editor variable references instead of Scheme variable
+references.
+
+Whether compiled or interpreted, the Emacs Lisp "primitives", even the
+likes of car and cdr, need to be emulated by procedures like el:car
+and el:cdr. Over 500 of these have already been implemented, though
+some will require modernization. Many can be punted entirely, like
+purify-flag, dump-emacs, cons-cells-consed, etc. A quick count of the
+DEFUNs and DEFVARs in Emacs23's src/ (including X, excluding Win32) is
+1737.
+
+We need to implement just 1200 more!
docstring
prompt
special-form?)
-(declare (integrate-operator %%subr?))
(declare (integrate-operator %subr?))
(define (%subr? obj)
(and (apply-hook? obj) (%%subr? (apply-hook-extra obj))))
+(declare (integrate-operator %make-subr))
(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)
+(declare (integrate-operator %subr-name))
+(define (%subr-name subr)
(%subr/name (apply-hook-extra subr)))
-(define-integrable (%subr-procedure subr)
+(declare (integrate-operator %subr-procedure))
+(define (%subr-procedure subr)
(%subr/procedure (apply-hook-extra subr)))
-(define-integrable (%subr-docstring subr)
+(declare (integrate-operator %subr-docstring))
+(define (%subr-docstring subr)
(%subr/docstring (apply-hook-extra subr)))
-(define-integrable (%subr-prompt subr)
+(declare (integrate-operator %subr-prompt))
+(define (%subr-prompt subr)
(%subr/prompt (apply-hook-extra subr)))
-(define-integrable (%subr-special-form? subr)
+(declare (integrate-operator %subr-special-form?))
+(define (%subr-special-form? subr)
(%subr/special-form? (apply-hook-extra subr)))
\ No newline at end of file
;;; editor variables, its value is kept consistent with the value of the
;;; Emacs symbol.
\f
-;; 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)
+ (constructor make-%symbol (name))
(predicate %%symbol?)
- ;(predicate false)
(print-procedure
(unparser/standard-method
"el: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+ +unbound+ '() '() false false-procedure
- '() '() '() '() '() '() '() '() '()))
+ (unbound! '())
+ (get-value '())
+ (set-value! '())
+ (get-default '())
+ (set-default! '())
+ (make-local! '())
+ (make-all-local! '())
+ (kill-local! '())
+ (set-docstring! '()))
\f
;;;; Special bindings stack.
(define *specpdl* '())
-(define-integrable (%specbind vars inits thunk)
+(declare (integrate-operator %specbind))
+(define (%specbind vars inits thunk)
(let ((saved-specpdl *specpdl*))
(%wind-one! (cons (cons vars inits) *specpdl*))
(let ((value (thunk)))
(%unwind! saved-specpdl)
value)))
-(define-integrable (%wind! saved-state)
+(declare (integrate-operator %wind!))
+(define (%wind! saved-state)
(cond ((eq? saved-state *specpdl*) unspecific)
((null? saved-state)
(error "Cannot wind to saved-state!" saved-state))
(define +unbound+ "elisp unbound variable tag")
(define +not-global+ "elisp non-global variable")
-(define-integrable %make-symbol make-%symbol)
+(declare (integrate-operator %make-symbol))
+(define (%make-symbol string)
+ (make-%symbol string))
(declare (integrate-operator ->%symbol))
(define (->%symbol obj)
(not (eq? +unbound+ fun))))
(define-integrable (%set-symbol-funbound! sym)
- (set-%symbol/function! (->%symbol sym) +unbound+)
- unspecific)
+ (set-%symbol/function! (->%symbol sym) +unbound+))
(define-integrable (%symbol-plist sym)
(%symbol/plist (->%symbol sym)))
;; Assume it's the empty list.
(error:%signal Qsetting-constant (list '()))))
+;; For the DEFVAR forms, to hack the value slot directly.
+(define-integrable %init-symbol-value! set-%symbol/value!)
+(define-integrable %symbol-initial-value %symbol/value)
+
(declare (integrate-operator %symbol-default))
(define (%symbol-default symbol)
(if (%%symbol? symbol)
;; any.
(let ((docstring
(if existing-variable
- (vector-ref existing-variable
- variable-index:description)
+ (variable-description existing-variable)
(%get symbol Qvariable-documentation)))
(default
(cond (existing-variable
(if existing-variable
(begin
(if docstring
- (vector-set! existing-variable
- variable-index:description docstring))
+ (set-variable-%description! existing-variable docstring))
(set-variable-default-value! existing-variable default)
existing-variable)
(make-variable (intern (%symbol-name symbol))
(map (lambda (buffer)
(undefine-variable-local-value! buffer edwin-variable))
(buffer-list))
- (vector-set! edwin-variable variable-index:buffer-local? false)
+ (set-variable-buffer-local?! edwin-variable false)
(set! bound? false)
unspecific))
(get-value
(set-docstring!
(lambda (docstring)
(if (not existing-variable)
- (vector-set! edwin-variable
- variable-index:description
- docstring))
+ (set-variable-%description! edwin-variable docstring))
unspecific)))
(set-%symbol/value! symbol +not-global+)
(set-%symbol/bound?! symbol bound?)
Trying to expand an abbrev in any other buffer clears abbrev-start-location.")
(DEFVAR Qlocal-abbrev-table
- (%symbol-value Qfundamental-mode-abbrev-table)
+ (%symbol-initial-value Qfundamental-mode-abbrev-table)
"Local (mode-specific) abbrev table of current buffer.")
(%make-variable-buffer-local! Qlocal-abbrev-table)
(start-inferior-repl!
(create-buffer "*scheme*")
(nearest-repl/environment)
- (nearest-repl/syntax-table)
(if (not (vector-ref edwin-variable$inhibit-startup-message 3))
(cmdl-message/append
(cmdl-message/active
(lambda () (update-buffer-list files)))))
'())
-(define (undo-buffer-local-bindings! buffer)
- ;; This is a version of undo-local-bindings! that doesn't require BUFFER
- ;; to be the current-buffer with installed bindings.
- ;; Caller must guarantee that interrupts are disabled.
- (let ((bindings (buffer-local-bindings buffer)))
- (vector-set! buffer buffer-index:local-bindings '())
- (if (current-buffer? buffer)
- (begin
- (do ((bindings bindings (cdr bindings)))
- ((null? bindings))
- (vector-set! (caar bindings)
- variable-index:value
- (variable-default-value (caar bindings))))
- (do ((bindings bindings (cdr bindings)))
- ((null? bindings))
- (invoke-variable-assignment-daemons! buffer (caar bindings)))))))
-
(DEFUN (el:kill-all-local-variables)
"Eliminate all the buffer-local variable values of the current buffer.
This buffer will then see the default values of all variables."
- ;; Modified version of undefine-variable-local-value!.
(without-interrupts
(lambda ()
(let* ((buffer (%current-buffer))
- (mode (guarantee-elisp-mode! buffer)))
- (undo-buffer-local-bindings! buffer)
+ (mode (guarantee-elisp-mode! buffer))
+ (current (current-buffer)))
+ (if (eq? buffer current)
+ (undo-local-bindings! buffer #t)
+ (set-buffer-local-bindings! buffer '()))
(%use-local-comtab! '())
- (%set-elisp-major-mode! mode Qfundamental-mode)
- (%set-elisp-mode-name! mode "Fundamental"))))
+ (set-variable-local-value! buffer (ref-variable-object major-mode)
+ Qfundamental-mode)
+ (set-mode-display-name! mode "Fundamental"))))
'())
(DEFVAR Qdefault-mode-line-format
(1d-table/put! elisp-symbol->edwin-mode-map sym mode)
mode))))|#
-(define major-mode-key "el:major-mode")
-
(DEFVAR Qmajor-mode
unassigned
"Symbol for current buffer's major mode.
(let* ((buffer (%current-buffer))
(mode (buffer-major-mode buffer)))
(if (elisp-mode? mode)
- (%elisp-major-mode mode)
+ (variable-local-value buffer (ref-variable major-mode))
(%intern (string-append "edwin:" (symbol->string (mode-name mode)))
initial-obarray))))
(lambda (value)
- (let* ((mode (guarantee-elisp-mode! (%current-buffer)))
- (val (CHECK-SYMBOL value)))
- (%set-elisp-major-mode! mode val)
+ (guarantee-elisp-mode! (%current-buffer))
+ (let ((val (CHECK-SYMBOL value)))
+ (set-variable-local-value! (%current-buffer)
+ (ref-variable-object major-mode)
+ val)
val)))
-(define (%elisp-major-mode mode)
- (or (mode-get mode major-mode-key) '()))
-
-(define (%set-elisp-major-mode! mode name)
- (mode-put! mode major-mode-key name))
+(define-variable major-mode
+ "ELisp symbol naming buffer's Emacs mode.")
(DEFVAR Qabbrev-mode
unassigned
NOTE: This variable can only be a string in Edwin."
(lambda ()
- (%elisp-mode-name (buffer-major-mode (%current-buffer))))
+ (mode-display-name (buffer-major-mode (%current-buffer))))
(lambda (value)
(let* ((mode (guarantee-elisp-mode! (%current-buffer)))
(name (CHECK-STRING value)))
- (%set-elisp-mode-name! mode name)
+ (set-mode-display-name! mode name)
name)))
-(define %elisp-mode-name mode-display-name)
-(define %set-elisp-mode-name! set-mode-display-name!)
-
(DEFVAR Qfill-column
unassigned ;(ref-variable fill-column)
"*Column beyond which automatic line-wrapping should happen.
'()))
(lambda (value)
(if (null? value)
- (set-buffer-writable! (%current-buffer))
+ (set-buffer-writeable! (%current-buffer))
(set-buffer-read-only! (%current-buffer)))
unspecific))
(%put! Qbuffer-read-only Qvariable-documentation
NOTE: This variable can only be a boolean in Edwin."
(lambda ()
- (if (vector-ref (%current-buffer) buffer-index:backed-up?)
+ (if (buffer-backed-up? (%current-buffer))
Qt
'()))
(lambda (value)
- (vector-set!
+ (set-buffer-backed-up?!
(%current-buffer)
- buffer-index:backed-up?
(cond ((eq? value Qt) true)
((null? value) false)
(else (error:wrong-type-datum value "a boolean"))))))
"Length of current buffer when last read in, saved or auto-saved.
0 initially."
(lambda ()
- (vector-ref (%current-buffer) buffer-index:save-length))
+ (buffer-%save-length (%current-buffer)))
(lambda (value)
- (vector-set! (%current-buffer) buffer-index:save-length value)))
+ (error "buffer-saved-size should be readonly?:" value)
+ (set-buffer-%save-length! (%current-buffer) value)))
(DEFVAR Qselective-display
unassigned
--- /dev/null
+#| -*-Scheme-*-
+
+Syntax the ELisp system. |#
+
+(load-option 'CREF)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+
+ ;; Build package structure.
+ (if (not (name->package '(ELISP)))
+ (let ((path (package-set-pathname "elisp")))
+ (cref/generate-trivial-constructor "elisp")
+ (construct-packages-from-file (fasload path))))
+
+ ;; Load compile-files, if necessary.
+ (let ((global-env (->environment '())))
+ (if (not (environment-bound? global-env 'compile-files))
+ (let ((toplev-env (->environment '(compiler top-level))))
+ (load "../compiler/base/toplev" toplev-env)
+ (environment-link-name global-env toplev-env 'compile-files))))
+
+ ;; Compile files.
+ (let* ((edwin-deps (map (lambda (base) (string-append "../edwin/" base))
+ '("struct" "comman" "modes" "buffer" "edtstr")))
+ (more-deps (cons "Buffers" edwin-deps))
+ (most-deps (cons "Symbols" more-deps))
+ (all-deps (cons* "Macros" "lisp" "Subrs" most-deps)))
+ (fluid-let ((compile-file:sf-only? #t))
+ (compile-file "Macros")
+ (load "Macros" (->environment '(ELISP)))
+ (compile-files '("Buffers") '(ELISP BUFFERS) edwin-deps)
+ (compile-files '("Symbols") '(ELISP SYMBOLS) more-deps)
+ (compile-files '("Subrs") '(ELISP SUBRS) most-deps)
+ (compile-files '("Reader") '(ELISP READER) most-deps)
+ (compile-files '("lisp") '(ELISP) most-deps)
+ (compile-files '("Misc" "data" "eval" "fns" "lread" "buffer"
+ "editfns" "fileio" "alloc" "minibuf"
+ "search" "callint" "syntax" "cmds"
+ "marker" "window" "keymap" "print"
+ "indent" "process" "dired" "abbrev"
+ "bytecode") '(ELISP) all-deps)))
+
+ ;; Cross-check.
+ (cref/generate-constructors "elisp" 'ALL)))
\ No newline at end of file
(%set-symbol-function! sym fun)
unspecific)
+;; Until there is an elisp/doc.scm...
+(define Qfunction-documentation
+ (%intern "function-documentation" initial-obarray))
+
+(DEFUN (el:defalias symbol definition #!optional docstring)
+ "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
+Associates the function with the current load file, if any.
+The optional third argument DOCSTRING specifies the documentation string
+for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
+determined by DEFINITION.
+
+NOTE: In Edwin, the function is NOT associated with the current file, yet."
+ (let* ((symbol (CHECK-SYMBOL symbol))
+ (func (and (%symbol-fbound? symbol)
+ (%symbol-function symbol))))
+ #;(define-integrable (loadhist-attach x)
+ (set! el:current-load-list (cons x el:current-load-list)))
+ (define-integrable (loadhist-attach x)
+ (declare (ignore x))
+ unspecific)
+ (if (and (pair? func) (eq? (car func) Qautoload))
+ (loadhist-attach (cons Qt symbol)))
+ (%fset! symbol definition)
+ (loadhist-attach (cons Qdefun symbol))
+ (if (not (either-default? docstring))
+ (el:put symbol Qfunction-documentation docstring))
+ (%make-edwin-command symbol definition)
+ definition))
+
(DEFUN (el:setplist sym newplist)
"Set SYMBOL's property list to NEWVAL, and return NEWVAL."
(%set-symbol-plist! (CHECK-SYMBOL sym) newplist)
--- /dev/null
+#| -*- Scheme -*-
+
+ELISP buffer packaging info |#
+
+(standard-scheme-find-file-initialization
+ '#(
+ ("Subrs" (elisp subrs))
+ ("Symbols" (elisp symbols))
+ ("Buffers" (elisp buffers))
+ ("Macros" (elisp syntax-extensions))
+ ("Reader" (elisp reader))
+
+ ("Misc" (elisp))
+ ("lisp" (elisp))
+ ("data" (elisp))
+ ("eval" (elisp))
+ ("fns" (elisp))
+ ("lread" (elisp))
+ ("buffer" (elisp))
+ ("editfns" (elisp))
+ ("fileio" (elisp))
+ ("alloc" (elisp))
+ ("minibuf" (elisp))
+ ("search" (elisp))
+ ("callint" (elisp))
+ ("syntax" (elisp))
+ ("cmds" (elisp))
+ ("marker" (elisp))
+ ("window" (elisp))
+ ("keymap" (elisp))
+ ("print" (elisp))
+ ("indent" (elisp))
+ ("process" (elisp))
+ ("dired" (elisp))
+ ("abbrev" (elisp))
+ ("bytecode" (elisp))))
\ No newline at end of file
(DEFUN (el:user-login-name)
"Return the name under which user logged in, as a string.
This is based on the effective uid, not the real uid."
- (unix/current-user-name))
+ (current-user-name))
(DEFUN (el:user-real-login-name)
"Return the name of the user's real uid, as a string.
NOTE: In Edwin, this is the current login name as given in utmp, NOT
the pw_gecos field from the /etc/passwd entry."
- (unix/current-user-name))
+ (current-user-name))
(DEFUN (el:system-name)
"Return the name of the machine you are running on, as a string."
(DEFUN (el:current-time-string)
"Return the current time, as a human-readable string."
- (if (not file-timestamp-pathname)
- (call-with-temporary-filename
- (lambda (path)
- (set! file-timestamp-pathname
- (merge-pathnames path "/tmp/")))))
- (file-touch file-timestamp-pathname)
- (unix/file-time->string
- (file-modification-time-direct file-timestamp-pathname)))
+ (decoded-time->string (local-decoded-time)))
\f
(DEFUN (el:insert . args)
"Any number of args, strings or chars. Insert them after point, moving point
+++ /dev/null
-#| -*-Scheme-*-
-
-Not generated by CREF! |#
-
-(declare (usual-integrations))
-\f
-(lambda (load key-alist)
- (let ((sf-and-load
- (lambda (files package #!optional syntax-table)
- (fluid-let ((sf/default-syntax-table
- (if (default-object? syntax-table)
- syntax-table/system-internal
- syntax-table)))
- (sf-conditionally files))
- (for-each (lambda (file) (load file 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))))
\ No newline at end of file
;;;; ELisp Packaging
\f
-(definitions "edwin/edwin")
-(definitions "runtime/runtim")
-
-(define-package (elisp)
- ;; Files in this package correspond to similarly named files in GNUemacs/src.
- ;; The other packages contain implementations of the abstract Emacs Lisp
- ;; object types.
- (files "Misc" "lisp" "data" "eval" "fns" "lread" "buffer" "editfns" "fileio"
- "alloc" "minibuf" "search" "callint" "syntax" "cmds" "marker"
- "window" "keymap" "print" "indent" "process" "dired" "abbrev"
- "bytecode")
- (parent (edwin))
- (import (edwin buffer-menu)
- update-buffer-list)
- (import (edwin prompt)
- %prompt-for-string
- *completion-confirm?*
- *default-string*
- *default-type*
- completion-procedure/complete-string
- completion-procedure/list-completions
- completion-procedure/verify-final-value?
- exit-typein-edit
- typein-edit-depth
- set-typein-string!
- typein-editor-thunk)
- (import (edwin regular-expression)
- match-group
- registers)
- (import (edwin command-reader)
- command-history
- quotify-sexp
- *command-argument*
- *next-argument*
- *next-message*
- *command-message*)
- (import (edwin command-summary)
- comtabs->alists
- sort-by-prefix)
- (import (edwin window)
- buffer-frame?
- inferior-window
- inferior-start
- inferior-size
- window-inferiors
- guarantee-window-configuration)
- (import (edwin comtab)
- comtab-get
- comtab-put!
- command&comtab?
- comtab-alias?
- comtab-alist
- set-comtab-alist!
- comtab-alist*
- comtab-vector
- set-comtab-vector!
- lookup-key
- %define-key
- guarantee-comtabs)
- (import (edwin process)
- process?
- process-subprocess
- process-input-queue
- poll-process-for-output)
- (import (runtime thread)
- block-on-input-descriptor))
+(global-definitions "../runtime/runtime")
+(global-definitions "../edwin/edwin")
(define-package (elisp subrs)
(files "Subrs")
(parent (elisp))
(export (elisp)
- %subr ;record type, used by inlined %subr?
- %subr?
- %make-subr
+ %subr? %%subr? ;because %subr? is integrated!
+ %make-subr make-%subr ;because %make-subr is integrated!
%subr-docstring
%subr-name
%subr-procedure
(files "Symbols")
(parent (elisp))
(export (elisp)
- %symbol ;record type, used by inlined %symbol?
- +unbound+ ;constant, used by %symbol-fbound?...
- +not-global+ ;constant, used by %symbol-value...
+ +unbound+ ;because %symbol-fbound? is integrated!
+ +not-global+ ;because %symbol-value is integrated!
*specpdl*
%specbind
%wind!
%wind-one! ;procedure, used by %specbind...
%unwind!
- %symbol?
- %make-symbol
+ %symbol? %%symbol? ;because %symbol? is integrated!
+ %make-symbol make-%symbol ;because %make-symbol is integrated!
%symbol-name
%symbol-function
%set-symbol-function!
%symbol-bound?
%set-symbol-unbound!
%symbol-value
+ %symbol-initial-value
+ %symbol/value ;because %symbol-initial-value is integrated!
%set-symbol-value!
+ %init-symbol-value!
+ set-%symbol/value! ;because %init-symbol-value! is integrated!
%symbol-default
%set-symbol-default!
%make-variable-buffer-local!
(files "Buffers")
(parent (elisp))
(export (elisp)
- elisp-current-buffer ;variable, used by %current-buffer...
+ elisp-current-buffer ;because %current-buffer is integrated!
%with-current-buffer
%current-buffer
%set-current-buffer!
%save-excursion))
-(define-package (elisp syntax-extensions)
- (files "Macros")
- (parent (elisp))
- (export (elisp)
- elisp-syntax-table)
- (import (runtime syntax-table)
- make-syntax-table
- syntax-table-define))
-
(define-package (elisp reader)
(files "Reader")
(parent (elisp))
(export (elisp)
- parse-elisp-object))
\ No newline at end of file
+ parse-elisp-object))
+
+(define-package (elisp)
+ ;; Files in this package correspond to similarly named files in
+ ;; Emacs' src/. The other packages contain implementations of the
+ ;; abstract Emacs Lisp object types.
+ (files "Macros" "Misc"
+ "lisp" "data" "eval" "fns" "lread" "buffer" "editfns" "fileio"
+ "alloc" "minibuf" "search" "callint" "syntax" "cmds" "marker"
+ "window" "keymap" "print" "indent" "process" "dired" "abbrev"
+ "bytecode")
+ (parent (edwin))
+ (import (edwin buffer-menu)
+ update-buffer-list)
+ (import (edwin prompt)
+ abort-typein-edit
+ exit-typein-edit
+ typein-edit-depth
+ set-typein-string!
+ typein-editor-thunk)
+ (import (edwin regular-expression)
+ match-group
+ registers)
+ (import (edwin command-reader)
+ command-history
+ quotify-sexp
+ *command-argument*
+ *next-argument*
+ *next-message*
+ *command-message*)
+ (import (edwin command-summary)
+ comtabs->alists
+ sort-by-prefix)
+ (import (edwin window)
+ buffer-frame?
+ inferior-window
+ inferior-start
+ inferior-size
+ window-inferiors
+ guarantee-window-configuration)
+ (import (edwin comtab)
+ comtab-get
+ comtab-put!
+ command&comtab?
+ comtab-alias?
+ comtab-alist
+ set-comtab-alist!
+ comtab-alist*
+ comtab-vector
+ set-comtab-vector!
+ lookup-key
+ %define-key
+ guarantee-comtabs)
+ (import (edwin process)
+ process?
+ process-subprocess
+ process-input-queue
+ poll-process-for-output))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1993, 2011 Matthew Birkholz
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(if (null? (name->package '(SCODE-OPTIMIZER TOP-LEVEL)))
- (with-working-directory-pathname
- (system-binary-root-directory-pathname 'sf)
- (lambda () (load "make"))))
-
-(if (null? (name->package '(CREF2)))
- (with-working-directory-pathname
- (system-binary-root-directory-pathname 'cref2)
- (lambda () (load "make"))))
-\f
-;;; Build package structure.
-
-(if (not (file-processed? "elisp" "pkg" "con"))
- (cref2/generate-trivial-constructor "elisp"))
-(if (not (file-processed? "elisp" "con" "bcon"))
- (sf "elisp.con" "elisp.bcon"))
-(if (not (file-processed? "elisp" "ldr" "bldr"))
- (sf "elisp.ldr" "elisp.bldr"))
-(if (not (name->package '(ELISP)))
- (load "elisp.bcon"))
-
-;;; Load files.
-
-(let ((sf-and-load
- (lambda (files package #!optional syntax-table)
- (fluid-let ((sf/default-syntax-table
- (if (default-object? syntax-table)
- syntax-table/system-internal
- syntax-table)))
- (sf-conditionally files))
- (for-each (lambda (file)
- (load (string-append file ".bin") package))
- files))))
- (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
(else form))))))
(define condition-type:%throw
- (make-condition-type 'el:throw () '(TAG VALUE) "emacs lisp throw"))
+ (make-condition-type 'EL:THROW #f '(TAG VALUE) "emacs lisp throw"))
(define error:%throw
(condition-signaller
unspecific))))
(define condition-type:%signal
- (make-condition-type 'EL:SIGNAL () '(NAME DATA)
+ (make-condition-type 'EL:SIGNAL #f '(NAME DATA)
(lambda (condition port)
(write-string "emacs lisp signal " port)
(write-string (%symbol-name (access-condition condition 'NAME)) port)
(loop (%symbol-function fun) (1+ i)))
(else unbound)))))
(cond ((eq? fun unbound) false)
- ((%subr? fun) (not (null? (%subr-prompt fun))))
+ ((%subr? fun) (if (null? (%subr-prompt fun)) nil Qt))
;; Substituting comtab? for vector?, since Emacs Lisp
;; emulator doesn't grok vectors as keymaps...
;;((vector? fun) true)
(cond ((not (%symbol? funcar))
(error:%signal Qinvalid-function (list fun)))
((eq? Qlambda funcar)
- (not (null? (el:assq Qinteractive (cddr fun)))))
+ (if (null? (el:assq Qinteractive (cddr fun))) nil Qt))
((eq? Qautoload funcar)
(eq? Qt (%car (%cdr (%cdr (%cdr fun))))))
(else '())))))))
((and (pair? function)
(eq? (car function) Qlambda)
(pair? (cdr function))
- (el:assq Qinteractive (cdr (cdr function))))
+ (pair? (cddr function))
+ (not-nil? (el:assq Qinteractive (cdr (cdr function)))))
=> (lambda (interactive-form)
(if (pair? (cdr interactive-form))
(cadr interactive-form)
(expand-file-name (CHECK-STRING name) (CHECK-STRING default))))
(define (expand-user-home-directory username)
- (if (string-null? username)
- (unix/current-home-directory)
- (bind-condition-handler
- (list condition-type:simple-error)
- (lambda (condition)
- condition
- (error:%signal
- Qerror
- (list (el:format "User \"%s\" is not known" username))))
- (lambda () (unix/user-home-directory username)))))
+ (let ((namestring
+ (if (string-null? username)
+ (->namestring (current-home-directory))
+ (bind-condition-handler
+ (list condition-type:simple-error)
+ (lambda (condition)
+ condition
+ (error:%signal
+ Qerror
+ (list (el:format "User \"%s\" is not known" username))))
+ (lambda () (->namestring (user-home-directory username)))))))
+ ;; Remove trailing slash.
+ (if (string-suffix? "/" namestring)
+ (string-head namestring (-1+ (string-length namestring)))
+ namestring)))
(define (expand-file-name name #!optional default)
;; merge-pathnames chokes on "//" and "$", so don't use pathname operations
and last save file modtime are set, and it is marked unmodified.
If visiting and the file does not exist, visiting is completed
before the error is signaled."
- (let ((buffer (%current-buffer)))
- (if (buffer-read-only? buffer)
- (barf-if-read-only))
- (let ((truename (expand-file-name (CHECK-STRING filename)))
- (visit? (not (either-default? visit)))
- (start (mark-right-inserting (buffer-point buffer)))
- (end (mark-left-inserting (buffer-point buffer))))
- (let ((modtime (and (file-readable? truename)
- (file-modification-time truename))))
- (define (set-file-info!)
- (if (not (false? modtime))
- (set-buffer-modification-time! buffer modtime))
- (set-buffer-pathname! buffer (->pathname filename))
- (set-buffer-truename! buffer (->pathname truename))
- (set-buffer-save-length! buffer)
- (buffer-not-modified! buffer)
- (undo-done! (buffer-point buffer)))
- (if (false? modtime)
- (begin
- (if visit? (set-file-info!))
- (error:%signal Qfile-error
- (list "Opening input file" truename)))
- (bind-condition-handler
- (list condition-type:file-error)
- (lambda (condition)
- condition
- (error:%signal Qfile-error
- (list "Opening input file" truename)))
- (lambda ()
- (bind-condition-handler
- (list condition-type:system-call-error)
- (lambda (condition)
- (error:%signal
- Qerror
- (list
- (string-append
- "IO error reading " truename ": "
- (string-replace
- (symbol->string
- (access-condition condition 'ERROR-TYPE))
- #\- #\Space)))))
- (lambda ()
- ;; Set modified so that file supercession check isn't done.
- (set-group-modified! (buffer-group buffer) true)
- (%fixup-window-point-movement
- buffer start
- (lambda () (%insert-file start truename visit?)))
- (set-buffer-point! buffer start)
- (set-file-info!))))))
- (list truename
- (- (mark-index end) (mark-index start)))))))
+ (bind-condition-handler
+ (list condition-type:file-error)
+ (lambda (condition)
+ (error:%signal Qfile-error
+ (list "Opening input file"
+ (access-condition condition 'FILENAME))))
+ (lambda ()
+ (let* ((point (mark-right-inserting (buffer-point (%current-buffer))))
+ (truename (->truename (get-pathname-or-alternate (mark-group point)
+ filename #t)))
+ (mark (mark-left-inserting point)))
+ (%insert-file point truename
+ (cond ((default-object? visit) #f)
+ ((null? visit) #f)
+ (else visit)))
+ (set-current-point! point)
+ (push-current-mark! mark)
+ (list truename (- (mark-index point) (mark-index mark)))))))
(DEFUN (el:write-region start end filename #!optional append visit)
"Write current region into specified file.
(write-region* region
filename
(if (eq? Qt visit) 'VISIT (not (null? visit)))
- (not (null? append)))))
- (set-buffer-truename! buffer truename)
- (delete-auto-save-file! buffer)
- (set-buffer-save-length! buffer)
- (buffer-not-modified! buffer)
- (set-buffer-modification-time!
- buffer (file-modification-time truename))
+ (not (null? append))
+ 'DEFAULT)))
+ (if (not (null? visit))
+ (begin
+ (set-buffer-truename! buffer truename)
+ (delete-auto-save-file! buffer)
+ (set-buffer-save-length! buffer)
+ (buffer-not-modified! buffer)
+ (set-buffer-modification-time!
+ buffer (file-modification-time truename))))
truename))))
(DEFUN (el:verify-visited-file-modtime buf)
The value is actually the tail of LIST whose car is ELT."
(let loop ((tail elts))
(cond ((null? tail) '())
- ((el:eq (el:car tail) elt) tail)
+ ((not (null? (el:eq (el:car tail) elt))) tail)
(else (loop (el:cdr tail))))))
(DEFUN (el:assq key alist)
'()
(let ((elt (el:car tail)))
(if (and (pair? elt)
- (el:eq (car elt) key))
+ (not (null? (el:eq (car elt) key))))
elt
(loop (cdr tail)))))))
'()
(let ((elt (el:car tail)))
(if (and (pair? elt)
- (el:equal (car elt) key))
+ (not (null? (el:equal (car elt) key))))
elt
(loop (cdr tail)))))))
'()
(let ((elt (el:car tail)))
(if (and (pair? elt)
- (el:eq (cdr elt) key))
+ (not (null? (el:eq (cdr elt) key))))
elt
(loop (cdr tail)))))))
(let loop ((tail elts)
(prev '()))
(cond ((null? tail) elts)
- ((el:eq (%car tail) elt)
+ ((not (null? (el:eq (%car tail) elt)))
(let ((cdr (cdr tail)))
(if (null? prev)
(set! elts cdr)
Conses are compared by comparing the cars and the cdrs.
Vectors and strings are compared element by element.
Numbers are compared by value. Symbols must match exactly."
- (cond ((mark? o1) (and (mark? o2) (mark= o1 o2)))
- (else (equal? o1 o2))))
+ (cond ((mark? o1) (if (and (mark? o2) (mark= o1 o2)) Qt nil))
+ (else (if (equal? o1 o2) Qt nil))))
(DEFUN (el:fillarray array item)
"Store each element of ARRAY with ITEM. ARRAY is a vector or string."
Also accepts Space to mean yes, or Delete to mean no."
;; This is a copy of `prompt-for-confirmation?' that appends "(y or n) "
;; rather than " (y or n)? " to `prompt'.
- (prompt-for-typein (string-append prompt "(y or n) ") false
+ (prompt-for-typein (if (string-suffix? " " prompt)
+ prompt
+ (string-append prompt " (y or n)? "))
+ #f
(lambda ()
- (let loop ((lost? false))
+ (let loop ((lost? #f))
(let ((char (keyboard-read)))
(cond ((and (char? char)
(or (char-ci=? char #\y)
(char-ci=? char #\space)))
- (set-typein-string! "y" true)
+ (set-typein-string! "y" #t)
Qt)
((and (char? char)
(or (char-ci=? char #\n)
(char-ci=? char #\rubout)))
- (set-typein-string! "n" true)
+ (set-typein-string! "n" #t)
'())
+ ((input-event? char)
+ (abort-typein-edit char))
(else
(editor-beep)
(if (not lost?)
(insert-string "Please answer y or n. "
(buffer-absolute-start (current-buffer))))
- (loop true)))))))
- #|(let loop ((prompt (CHECK-STRING prompt)))
- (el:message "%s(y or n) " prompt)
- (let ((ans (keyboard-read-char)))
- (el:message "%s(y or n) %c" prompt ans)
- (case ans
- ((#\Y #\y #\ )
- Qt)
- ((#\N #\n #\delete)
- '())
- (else (el:ding '())
- (discard-input)
- (loop (if (string-prefix? "Please answer y or n. " prompt)
- prompt
- (string-append "Please answer y or n. " prompt)))))))|#)
+ (loop #t))))))))
(DEFUN (el:yes-or-no-p prompt)
"Ask user a yes or no question. Return t if answer is yes.
(if (string-ci=?
"Yes"
(prompt-for-typein
- (string-append prompt "(yes or no) ") true
+ (string-append prompt "(yes or no) ") #t
(typein-editor-thunk (ref-mode-object minibuffer-local-yes-or-no))))
- Qt '())
- #|(let loop ((prompt (string-append (CHECK-STRING prompt) "(yes or no) ")))
- (let ((ans (el:read-from-minibuffer prompt)))
- (cond ((string-ci=? ans "yes")
- Qt)
- ((string-ci=? and "no")
- '())
- (else
- (el:ding '())
- (discard-input)
- (el:message "Please answer yes or no.")
- (el:sleep-for 2)
- (loop
- (if (string-prefix? "Please answer yes or no. " prompt)
- prompt
- (string-append "Please answer yes or no. " prompt)))))))|#)
+ Qt '()))
#|(DEFUN (el:load-average)
"Return the current 1 minute, 5 minute and 15 minute load averages
#|
In GNU Emacs, (major) modes are defined implicitly by the buffer-local
-settings of variables like major-mode and mode-name, and of the
-local-map.
-
-In Edwin, major modes are objects containing these values in their fields.
-
-To implement GNU Emacs modes in terms of Edwin major modes, an
-anonymous Edwin mode is created per buffer. This anonymous "ELisp mode"
-will contain the buffer-local settings of GNU Emacs variables like
-major-mode and mode-name, and of the local-map. The ELisp mode will be
-created when any of the variables are set, and will become the major mode
-for the buffer. References to any of the variables will return the
-appropriate value per the current mode, whether an anonymous Edwin mode or
-a normal Edwin mode.
-
-GNU Emacs keymaps are implemented by Edwin comtabs. This breaks
+settings of variables like major-mode and mode-name, and the local
+keymap.
+
+In Edwin, major modes contain these values in their fields -- not in
+buffer-local storage. Multiple Emacs buffers with the same major-mode
+need not have the same mode-name nor local keymap, while multiple
+Edwin buffers in the same major-mode *must*.
+
+Thus buffers created by Emacs code are each given a unique,
+anonymous "ELisp mode" for their major mode. This provides
+buffer-local storage for a mode-name and local keymap. The major-mode
+variable is implemented by a buffer-local Edwin variable of the same
+name. The elisp mode is "anonymous" because it does not appear in
+Edwin's editor-modes table.
+
+GNU Emacs local keymaps are implemented by Edwin comtabs. This breaks
programs that rely on frobbing the exposed rep of GNU Emacs keymaps,
but there's little can be done about that. el:define-key will create an
anonymous command that calls %call-interactive on the datum, be it
(if (and (pair? chars)
(char=? (car chars) #\Altmode)
(pair? (cdr chars)))
- (cons (char-metafy (car (cdr chars))) (cddr chars))
+ (cons (set-char-bits char-bit:meta (car (cdr chars))) (cddr chars))
chars)))
(define elisp-comtab-binding-tag "??")
(%symbol-command datum))
(else
(let ((command (%make-command)))
- (vector-set! command command-index:name
- (string->symbol elisp-comtab-binding-tag))
- (vector-set! command command-index:description
- elisp-comtab-binding-tag)
- (vector-set! command command-index:interactive-specification
- (lambda () (list datum)))
- (vector-set! command command-index:procedure
- %keymap-dispatch)
+ (set-command-name! command (string->symbol elisp-comtab-binding-tag))
+ (set-command-%description! command elisp-comtab-binding-tag)
+ (set-command-interactive-specification! command
+ (lambda () (list datum)))
+ (set-command-procedure! command %keymap-dispatch)
command))))
(define (%keymap-dispatch datum)
result))
(let ((entry (cond ((and (comtab? (cdar alist))
(char-ascii? (caar alist)))
- (cons (string-append-char prefix (caar alist))
+ (cons (string-append prefix (string (caar alist)))
(cdar alist)))
((and (command&comtab? (cdar alist))
(char-ascii? (caar alist)))
- (cons (string-append-char prefix (caar alist))
+ (cons (string-append prefix (string (caar alist)))
(cdr (cdar alist))))
(else false))))
(if entry
(let ((elisp-defn
(car ((command-interactive-specification defn)))))
(if (pair? definition)
- (el:equal definition elisp-defn)
+ (not (null? (el:equal definition elisp-defn)))
(eq? definition elisp-defn)))
(eq? (lookup-key local-keymap keys) defn))
(if first-only?
;; local-keymap, the first pair in the mode's list of comtabs must be
;; preserved, since the buffer's list of comtabs shares it.
-;;; convenient access/manipulation of mode properties
-
-(define (mode-get mode key)
- (let ((entry (assq key (mode-alist mode))))
- (and entry (cdr entry))))
-
-(define (mode-put! mode key value)
- (let ((entry (assq key (mode-alist mode))))
- (if entry
- (set-cdr! entry value)
- (set-mode-alist! mode (cons (cons key value)
- (mode-alist mode)))))
- unspecific)
-
-
-;;; get/create elisp-mode (not edwin-mode) of buffer
-
-(define elisp-mode-buffer-tag "elisp-mode")
-
-(define (elisp-mode/buffer mode)
- (mode-get mode elisp-mode-buffer-tag))
-
-(define elisp-mode? elisp-mode/buffer)
+(define (elisp-mode? mode)
+ (not (eq? mode (name->mode (mode-name mode) #f))))
(define (guarantee-elisp-mode! buffer)
(let ((mode (buffer-major-mode buffer)))
(list (%global-comtab)))))
(set-mode-display-name! elisp-mode "Fundamental")
(set-mode-major?! elisp-mode true)
- (set-mode-description!
+ (set-mode-%description!
elisp-mode
"Anonymous Emacs Lisp mode, describing Emacs' notion of the
-state of its associated Edwin buffer, which is:
-
- (elisp-mode/buffer <this-mode>).")
+state of its associated Edwin buffer.")
(set-mode-initialization! elisp-mode (lambda (buffer)
buffer unspecific))
- (set-mode-alist! elisp-mode '())
- (mode-put! elisp-mode elisp-mode-buffer-tag buffer)
- (%set-elisp-mode-name! mode "Fundamental")
- (%set-elisp-major-mode! mode Qfundamental-mode)
+ (set-variable-local-value! buffer (ref-variable-object major-mode)
+ Qfundamental-mode)
(set-buffer-major-mode! buffer elisp-mode)
elisp-mode))))
;;;; Fundamental definitions for GNU Emacs Lisp interpreter.
;;; package: (elisp)
\f
+(define-integrable nil '())
+
+(declare (integrate-operator not-nil?))
+(define (not-nil? object)
+ ;; Not quite the same as (not (null? object)), which is #t or #f.
+ (if (null? object) #f object))
+
+(declare (integrate-operator either-default?))
+(define (either-default? value)
+ (or (default-object? value) (null? value)))
+
(declare (integrate-operator CHECK-LIST))
(define (CHECK-LIST x)
(if (or (pair? x) (null? x))
--- /dev/null
+;;; loadup.el --- load up standardly loaded Lisp files for Emacs
+
+;; This file is part of MIT/GNU Scheme.
+
+;; MIT/GNU Scheme is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of the
+;; License, or (at your option) any later version.
+
+;; MIT/GNU Scheme is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with MIT/GNU Scheme; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+;; 02110-1301, USA.
+
+;;; Commentary:
+
+;; This is loaded into a bare Emacs Lisp emulator in Edwin. It is a
+;; slightly edited version of Emacs' loadup.el. Progress messages,
+;; calls to the garbage collector, the DOC file build, and the dumping
+;; of an executable have been removed, but that is about it.
+
+;;; Code:
+
+(setq load-path '("~/emacs/lisp"))
+
+;; add subdirectories to the load-path for files that might
+;; get autoloaded when bootstrapping
+(let ((dir (car load-path)))
+ (setq load-path (list dir
+ (expand-file-name "emacs-lisp" dir)
+ (expand-file-name "language" dir)
+ (expand-file-name "international" dir)
+ (expand-file-name "textmodes" dir))))
+
+(load "emacs-lisp/byte-run")
+(load "emacs-lisp/backquote")
+(load "subr")
+
+;; We specify .el in case someone compiled version.el by mistake.
+(load "version.el")
+
+(load "widget")
+(load "custom")
+(load "emacs-lisp/map-ynp")
+(load "cus-start")
+(load "international/mule")
+(load "international/mule-conf.el") ;Don't get confused if someone compiled this by mistake.
+(load "env")
+(load "format")
+(load "bindings")
+(setq load-source-file-function 'load-with-code-conversion)
+(load "files")
+
+(load "cus-face")
+(load "faces") ; after here, `defface' may be used.
+(load "minibuffer")
+
+(load "button")
+(load "startup")
+
+(condition-case nil
+ ;; Don't get confused if someone compiled this by mistake.
+ (load "loaddefs.el")
+ ;; In case loaddefs hasn't been generated yet.
+ (file-error (load "ldefs-boot.el")))
+
+(load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table.
+(load "simple")
+
+(load "help")
+
+(load "jka-cmpr-hook")
+(load "epa-hook")
+;; Any Emacs Lisp source file (*.el) loaded here after can contain
+;; multilingual text.
+(load "international/mule-cmds")
+(load "case-table")
+(load "international/characters")
+(load "composite")
+;; This file doesn't exist when building Emacs from CVS. It is
+;; generated just after temacs is build.
+(load "international/charprop.el" t)
+
+;; Load language-specific files.
+(load "language/chinese")
+(load "language/cyrillic")
+(load "language/indian")
+(load "language/sinhala")
+(load "language/english")
+(load "language/ethiopic")
+(load "language/european")
+(load "language/czech")
+(load "language/slovak")
+(load "language/romanian")
+(load "language/greek")
+(load "language/hebrew")
+(load "language/japanese")
+(load "language/korean")
+(load "language/lao")
+(load "language/tai-viet")
+(load "language/thai")
+(load "language/tibetan")
+(load "language/vietnamese")
+(load "language/misc-lang")
+(load "language/utf-8-lang")
+(load "language/georgian")
+(load "language/khmer")
+(load "language/burmese")
+(load "language/cham")
+
+(load "indent")
+(load "window")
+(load "frame")
+(load "term/tty-colors")
+(load "font-core")
+;; facemenu must be loaded before font-lock, because `facemenu-keymap'
+;; needs to be defined when font-lock is loaded.
+(load "facemenu")
+(load "emacs-lisp/syntax")
+(load "font-lock")
+(load "jit-lock")
+
+(if (fboundp 'track-mouse)
+ (progn
+ (load "mouse")
+ (and (boundp 'x-toolkit-scroll-bars)
+ (load "scroll-bar"))
+ (load "select")))
+(load "emacs-lisp/timer")
+(load "isearch")
+(load "rfn-eshadow")
+
+(load "menu-bar")
+(load "paths.el") ;Don't get confused if someone compiled paths by mistake.
+(load "emacs-lisp/lisp")
+(load "textmodes/page")
+(load "register")
+(load "textmodes/paragraphs")
+(load "emacs-lisp/lisp-mode")
+(load "textmodes/text-mode")
+(load "textmodes/fill")
+
+(load "replace")
+(load "buff-menu")
+
+(if (fboundp 'x-create-frame)
+ (progn
+ (load "fringe")
+ (load "image")
+ (load "international/fontset")
+ (load "dnd")
+ (load "mwheel")
+ (load "tool-bar")))
+(if (featurep 'x)
+ (progn
+ (load "x-dnd")
+ (load "term/common-win")
+ (load "term/x-win")))
+
+(if (eq system-type 'windows-nt)
+ (progn
+ (load "w32-vars")
+ (load "term/common-win")
+ (load "term/w32-win")
+ (load "ls-lisp")
+ (load "disp-table")
+ (load "dos-w32")
+ (load "w32-fns")))
+(if (eq system-type 'ms-dos)
+ (progn
+ (load "dos-w32")
+ (load "dos-fns")
+ (load "dos-vars")
+ ;; Don't load term/common-win: it isn't appropriate for the `pc'
+ ;; ``window system'', which generally behaves like a terminal.
+ (load "term/pc-win")
+ (load "ls-lisp")
+ (load "disp-table"))) ; needed to setup ibm-pc char set, see internal.el
+(if (eq system-type 'macos)
+ (progn
+ (load "ls-lisp")))
+(if (featurep 'ns)
+ (progn
+ (load "emacs-lisp/easymenu") ;; for platform-related menu adjustments
+ (load "term/ns-win")))
+(if (fboundp 'atan) ; preload some constants and
+ (progn ; floating pt. functions if we have float support.
+ (load "emacs-lisp/float-sup")))
+
+(load "vc-hooks")
+(load "ediff-hook")
+(if (fboundp 'x-show-tip) (load "tooltip"))
+
+;If you want additional libraries to be preloaded and their
+;doc strings kept in the DOC file rather than in core,
+;you may load them with a "site-load.el" file.
+;But you must also cause them to be scanned when the DOC file
+;is generated.
+;For other systems, you must edit ../src/Makefile.in.
+(load "site-load" t)
+
+(if (fboundp 'x-popup-menu)
+ (precompute-menubar-bindings))
+;; Turn on recording of which commands get rebound,
+;; for the sake of the next call to precompute-menubar-bindings.
+(setq define-key-rebound-commands nil)
+
+;; Determine which last version number to use
+;; based on the executables that now exist.
+(if (not (eq system-type 'ms-dos))
+ (let* ((base (concat "emacs-" emacs-version "."))
+ (files (file-name-all-completions base default-directory))
+ (versions (mapcar (function (lambda (name)
+ (string-to-int (substring name (length base)))))
+ files)))
+ ;; `emacs-version' is a constant, so we shouldn't change it with `setq'.
+ (defconst emacs-version
+ (format "%s.%d"
+ emacs-version (if versions (1+ (apply 'max versions)) 1)))))
+
+;;;Note: You can cause additional libraries to be preloaded
+;;;by writing a site-init.el that loads them.
+;;;See also "site-load" above.
+(load "site-init" t)
+(setq current-load-list nil)
+(setq load-history (mapcar 'purecopy load-history))
+(setq symbol-file-load-history-loaded t)
+
+(set-buffer-modified-p nil)
+
+(clear-charset-maps)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Build the Elisp system. |#
+
+(load-option 'EDWIN)
+(with-loader-base-uri (system-library-uri "elisp/")
+ (lambda ()
+ (load-package-set "elisp")))
+(add-subsystem-identification! "ELisp" '(0 1))
\ No newline at end of file
(continue false))
(lambda ()
(return (open-input-file filename))))))))
- false)))
+ '())))
(DEFVAR Qstandard-input
Qt
(else (error:%signal Qinvalid-function (list stream))))))
(define (make-%function-input-port function)
- (port/copy %function-input-port/template
+ (make-port %function-input-port-type
(make-%function-input-port-state function)))
(define-structure (%function-input-port-state
(unread-char (%function-input-port-state/peeked-char state)))
(if unread-char
(begin
- (set-%function-input-port-state/peeked-char! state ())
+ (set-%function-input-port-state/peeked-char! state #f)
unread-char)
(%funcall (%function-input-port-state/function state) '()))))
(set-%function-input-port-state/peeked-char! state char)
char))))
-(define %function-input-port/template
- (make-input-port
- `((PEEK-CHAR ,%function-input-port/peek-char)
- (READ-CHAR ,%function-input-port/read-char))
- ()))
+(define (%function-input-port/unread-char port char)
+ (set-%function-input-port-state/peeked-char! (port/state port) char))
+
+(define %function-input-port-type
+ (make-port-type
+ `((READ-CHAR ,%function-input-port/read-char)
+ (PEEK-CHAR ,%function-input-port/peek-char)
+ (UNREAD-CHAR ,%function-input-port/unread-char))
+ #f))
(DEFVAR Qvalues
'()
+++ /dev/null
-#| -*-Scheme-*-
-
-This file automatically loads the elisp package. |#
-
-(package/system-loader "elisp" '() false)
-(in-package (->environment '(elisp)) (load-essential-elisp))
\ No newline at end of file
If NUMBER is nil, makes marker point nowhere.
Then it no longer slows down editing in any buffer.
Returns MARKER."
- (let* ((old-marker (CHECK-MARKER marker))
+ (let* ((marker (CHECK-MARKER marker))
(buffer (if (either-default? buffer)
(%current-buffer)
(CHECK-BUFFER buffer)))
(lambda (mark group)
(%record-set! mark 1 group))))
(if new-index
- (let ((old-group (mark-group old-marker))
+ (let ((old-group (mark-group marker))
(new-group (buffer-group buffer)))
(if (and old-group
(not (eq? old-group new-group)))
- (mark-temporary! mark))
+ (mark-temporary! marker))
(set-mark-index! marker new-index)
(set-mark-group! marker new-group)
(mark-permanent! marker))
(mark-temporary! marker)
(set-mark-group! marker false)
(set-mark-index! marker false)))
- old-marker))
+ marker))
(DEFUN (el:copy-marker marker)
"Return a new marker pointing at the same place as MARKER.
;;; package: (elisp)
#|
-The basis of Emacs minibuffer interaction is read_minibuf. The basis of
-Edwin minibuffer interaction is %prompt-for-string.
-
-For completion, Emacs uses special keymaps that provide completion
-commands. To communicate to the completion commands how to do the
-completion, three variables are %specbind'd:
-Qminibuffer-completion-table,
-Qminibuffer-completion-predicate, and
-Qminibuffer-completion-confirm.
-
-Edwin uses special comtabs that provide completion commands. To
-communicate to the completion commands how to do the completion, procedures
-are fluid-bound to six global variables:
-typein-edit-continuation
-typein-edit-depth
-typein-saved-buffers
-typein-saved-windows
-map-name/internal->external
-map-name/external->internal
+The kernel of Emacs minibuffer interaction is read_minibuf. The kernel of
+Edwin minibuffer interaction is prompt-for-typein.
+
+Emacs uses special keymaps that provide completion commands. To
+communicate to the completion commands how to do the completion, three
+variables are %specbind'd:
+
+ Qminibuffer-completion-table,
+ Qminibuffer-completion-predicate, and
+ Qminibuffer-completion-confirm.
+
+Edwin also uses special comtabs to provide completion commands, and
+communicates to these commands how to do the completion by fluid-
+binding procedures to global variables, e.g.
+
+ map-name/internal->external
+ map-name/external->internal
+
+or providing options to the prompt-for- procedures, e.g.
+
+ 'REQUIRE-MATCH? 'CONFIRM
+ 'DEFAULT-TYPE 'VISIBLE-DEFAULT
By providing procedures that use the values of the Emacs variables, we
can get behavior similar to Emacs.
-To handle arbitrary keymaps, keymap->mode creates an anonymous/temporary
-mode object that uses the given comtab. This mode object is handed to
-%prompt-for-string. |#
+To handle arbitrary keymaps, keymap->mode creates an anonymous/
+temporary mode object that uses the given comtab. This mode object is
+passed as an option. |#
\f
(DEFUN (el:read-from-minibuffer prompt #!optional initial-input keymap read)
"Read a string from the minibuffer, prompting with string PROMPT.
(mode (keymap->mode (if (either-default? keymap)
(%symbol-value Qminibuffer-local-map)
keymap))))
- (fluid-let ((*default-string* initial-input)
- (*default-type* 'INSERTED-DEFAULT))
- (let ((input-string (%prompt-for-string prompt mode)))
- (if (either-default? read)
- input-string
- (car (el:read-from-string input-string)))))))
+ (let ((input-string (prompt-for-string prompt initial-input
+ 'MODE mode
+ 'DEFAULT-TYPE 'inserted-default)))
+ (if (either-default? read)
+ input-string
+ (car (el:read-from-string input-string))))))
(DEFUN (el:read-minibuffer prompt #!optional initial-contents)
"Return a Lisp object read using the minibuffer.
(%funcall alist (list string (or pred '()) '()))
(let ((completion (%try-completion string alist pred)))
(case completion
- (#f '())
- (#t Qt)
+ ((#f) '())
+ ((#t) Qt)
(else completion))))))
(define (alist-or-obarray-map alist-obarray receiver)
(list (%symbol-value Qminibuffer-help-form)
table
pred
- (if (eq? require-match? Qt) '() Qt))
+ require-match?)
(lambda ()
- (fluid-let
- ((*default-string* init)
- (*default-type* 'INSERTED-DEFAULT)
- (completion-procedure/complete-string
- (lambda (string if-unique if-not-unique if-not-found)
- (let ((completion (el:try-completion string table pred)))
- (cond ((null? completion)
- (if-not-found))
- ((eq? completion Qt)
- (if-unique string))
- (else
- (if-not-unique completion
- (lambda ()
- (el:all-completions string
- table pred))))))))
- (completion-procedure/list-completions
- (lambda (string)
- (sort (el:all-completions string table pred)
- string<?)))
- (completion-procedure/verify-final-value?
- (lambda (string)
- (let ((found? false))
- (alist-or-obarray-map
- table
- (lambda (eltstring elt)
- elt
- (if (string=? string eltstring)
- (set! found? true))))
- found?)))
- (*completion-confirm?* (if (eq? require-match? Qt) false true)))
- (%prompt-for-string
- prompt
- (keymap->mode (%symbol-value
- (if require-match?
- Qminibuffer-local-completion-map
- Qminibuffer-local-must-match-map)))))))))
+ (prompt-for-completed-string
+ prompt init
+ (named-lambda (el:complete-string string if-unique
+ if-not-unique if-not-found)
+ (let ((completion (el:try-completion string table pred)))
+ (cond ((null? completion)
+ (if-not-found))
+ ((eq? completion Qt)
+ (if-unique string))
+ (else
+ (if-not-unique completion
+ (lambda ()
+ (el:all-completions string
+ table pred)))))))
+ (named-lambda (el:list-completions string)
+ (sort (el:all-completions string table pred) string<?))
+ (named-lambda (el:verify-final-value? string)
+ (let ((found? false))
+ (alist-or-obarray-map
+ table
+ (lambda (eltstring elt)
+ elt
+ (if (string=? string eltstring)
+ (set! found? true))))
+ found?))
+ 'DEFAULT-TYPE 'INSERTED-DEFAULT
+ 'MODE (keymap->mode
+ (%symbol-value
+ (if require-match?
+ Qminibuffer-local-completion-map
+ Qminibuffer-local-must-match-map)))
+ 'REQUIRE-MATCH? (cond ((eq? require-match? #f) #f)
+ ((eq? require-match? Qt) #t)
+ (else 'CONFIRM)))))))
(DEFUN (el:minibuffer-complete)
"Complete the minibuffer contents as far as possible."
(list comtab))))
(set-mode-display-name! elisp-mode "emacs minibuffer mode")
(set-mode-major?! elisp-mode true)
- (set-mode-description!
+ (set-mode-%description!
elisp-mode
"Anonymous Emacs Lisp minibuffer mode, using an
arbitrary comtab in the minibuffer.")
(set-mode-initialization! elisp-mode (lambda (buffer)
buffer unspecific))
- (set-mode-alist! elisp-mode '())
elisp-mode)))))
-(define-major-mode minibuffer-local-noblanks fundamental false
+(define-major-mode minibuffer-local-noblanks fundamental #f
"Major mode for editing input strings that may not contain blanks.
The following commands are special to this mode:
(%with-current-buffer
buffer
(lambda ()
- (set-buffer-writable! buffer)
+ (set-buffer-writeable! buffer)
(el:erase-buffer)
(%specbind
(list Qstandard-output)
(if (not (either-default? proc))
(let ((process (CHECK-PROCESS-COERCE proc)))
(let loop ()
- (if (not (or (memq process (car process-input-queue))
- (poll-process-for-output process)))
+ (if (not (without-interrupts
+ (lambda ()
+ (or (memq process (car process-input-queue))
+ (not (eq? 'RUN (process-status process)))
+ (poll-process-for-output process)))))
(begin
- (block-on-input-descriptor
+ (outf-console ";Loop looking for output from "process".\n")
+ ;; Is this necessary?
+ #;(block-on-input-descriptor
(channel-descriptor-for-select
(subprocess-output-channel
(process-subprocess process))))
For index of first char beyond the match, do (match-end 0).
match-end and match-beginning also give indices of substrings
matched by parenthesis constructs in the pattern."
- (let ((regexp (CHECK-STRING regexp))
- (string (CHECK-STRING string))
- (fold-case? (not (null? (%symbol-value Qcase-fold-search)))))
- (let* ((length (string-length string))
- (start
- (if (either-default? start)
- 0
- (let ((start (CHECK-NUMBER start)))
- (if (negative? start)
- (if (<= (- start) length)
- (+ length start)
- (error:%signal Qargs-out-of-range
- (list string start)))
- (if (<= start length)
- start
- (error:%signal Qargs-out-of-range
- (list string start))))))))
- (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)
- '()))))
+ (let* ((regexp (CHECK-STRING regexp))
+ (string (CHECK-STRING string))
+ (fold-case? (not (null? (%symbol-value Qcase-fold-search))))
+ (length (string-length string))
+ (start
+ (if (either-default? start)
+ 0
+ (let ((start (CHECK-NUMBER start)))
+ (if (negative? start)
+ (if (<= (- start) length)
+ (+ length start)
+ (error:%signal Qargs-out-of-range
+ (list string start)))
+ (if (<= start length)
+ start
+ (error:%signal Qargs-out-of-range
+ (list string start)))))))
+ (syntax-table (ref-variable syntax-table (%current-buffer)))
+ (result
+ (re-substring-search-forward regexp string start length
+ fold-case? syntax-table)))
+ (if result
+ (re-match-start-index 0 result)
+ '())))
(DEFUN (el:skip-chars-forward string #!optional lim)
"Move point forward, stopping before a char not in CHARS, or at position LIM.
if a match began at index 0 in the string."
(let* ((group (object-unhash match-group))
(->data (lambda (pos)
- (if group
- (make-mark group pos)
- ;; For string-match: punt GNU Emacs' goofy
- ;; markers/int's. Just use integers!
- pos))))
+ (if group (make-mark group pos) pos))))
(let loop ((i 0) (positions '()))
(if (or (= i 10)
(not (re-match-start-index i)))
(reverse! positions)
(loop (1+ i)
- (cons (->data (re-match-end-index i))
- (cons (->data (re-match-start-index i))
- positions)))))))
+ (cons* (->data (re-match-end-index i))
+ (->data (re-match-start-index i))
+ positions))))))
(DEFUN (el:store-match-data positions)
"Set internal data on last search match from elements of LIST.
(DEFUN (el:syntax-table-p obj)
"Return t if ARG is a syntax table.
Any vector of 256 elements will do."
- (syntax-table? obj))
+ (char-syntax-table? obj))
(define (guarantee-syntax-table table)
- (if (syntax-table? table)
+ (if (char-syntax-table? table)
table
(wrong-type-argument el:syntax-table-p table)))
(DEFUN (el:standard-syntax-table)
"Return the standard syntax table.
This is the one used for new buffers."
- standard-syntax-table)
+ standard-char-syntax-table)
(DEFUN (el:copy-syntax-table #!optional table)
"Construct a new syntax table and return it.
It is a copy of the TABLE, which defaults to the standard syntax table."
- (let ((table (if (default-object? table)
- standard-syntax-table
- (guarantee-syntax-table table))))
- (%make-syntax-table (vector-copy (syntax-table/entries table)))))
+ (make-char-syntax-table table))
(DEFUN (el:set-syntax-table table)
"Select a new syntax table for the current buffer.
(guarantee-syntax-table syntax-table)))
(char (CHECK-CHAR c))
(str (CHECK-STRING newentry)))
- (modify-syntax-entry! syntax-table char str)))
+ (modify-syntax-entries! syntax-table char char str)))
(DEFUN (el:describe-syntax)
"Describe the syntax specifications in the syntax table.
(define (scan-lists-or-sexps from count depth sexp?)
(let ((buffer (%current-buffer)))
(let ((group (buffer-group buffer))
- (syntax-entries (syntax-table/entries
+ (syntax-entries (char-syntax-table/entries
(ref-variable syntax-table buffer))))
(let loop ((count count)
(depth depth)
(let ((screen (selected-screen)))
(let ((configuration-inside (screen-window-configuration screen))
(configuration-outside))
- (unwind-protect
+ (dynamic-wind
(lambda ()
(set! configuration-outside (screen-window-configuration screen))
- (set-screen-window-configuration! screen configuration-inside)
- unspecific)
+ (set-screen-window-configuration! screen configuration-inside))
thunk
(lambda ()
- (set! configuration-inside (screen-window-configuration
- screen))
- (set-screen-window-configuration! screen configuration-outside)
- unspecific)))))
+ (set! configuration-inside (screen-window-configuration screen))
+ (set-screen-window-configuration! screen configuration-outside))))))
#|(DEFVAR Qminibuffer-prompt-width
unassigned
(with-working-directory-pathname "sos"
(lambda ()
(load "load")))
- (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp" "ffi")))
+ (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp" "ffi" "elisp")))
(define (compile-boot-dirs compile-dir)
(compile-cref compile-dir)
run_cmd ln -s machines/"${MDIR}" compiler/machine
run_cmd ln -s machine/compiler.pkg compiler/.
-BUNDLES="6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml"
+BUNDLES="6001 compiler cref edwin elisp ffi imail sf sos ssp star-parser"
+BUNDLES="$BUNDLES xdoc xml"
run_cmd ${HOST_SCHEME_EXE} --batch-mode --heap 4000 <<EOF
(begin
(define-load-option 'CREF
(guarded-system-loader '(cross-reference) "cref"))
+(define-load-option 'ELISP
+ (guarded-system-loader '(elisp) "elisp"))
+
(define-load-option 'FFI
(guarded-system-loader '(ffi) "ffi"))
projects / mit-scheme.git / commitdiff