From: Matt Birkholz Date: Sat, 11 Jun 2011 00:02:46 +0000 (-0700) Subject: Updated to 9.0.1. X-Git-Tag: 20110610-ELisp^0 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1b7fbe1739276c62444fb443cf749c4e9c9fa159;p=mit-scheme.git Updated to 9.0.1. --- diff --git a/src/README.txt b/src/README.txt index 0c21c3d50..c3a802e8b 100644 --- a/src/README.txt +++ b/src/README.txt @@ -82,6 +82,8 @@ These are miscellaneous extras: 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 diff --git a/src/Setup.sh b/src/Setup.sh index db62f1d56..ade9b0737 100755 --- a/src/Setup.sh +++ b/src/Setup.sh @@ -75,7 +75,7 @@ fi . 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 @@ -85,6 +85,7 @@ maybe_link lib/include ../microcode maybe_link lib/optiondb.scm ../etc/optiondb.scm maybe_link lib/runtime ../runtime maybe_link lib/mit-scheme.h ../microcode/pruxffi.h +maybe_link lib/elisp ../elisp maybe_link lib/ffi ../ffi maybe_link lib/ffi-test-shim.so ../ffi/ffi-test-shim.so maybe_link lib/ffi-test-types.bin ../ffi/ffi-test-types.bin diff --git a/src/TAGS b/src/TAGS index e0668593b..6422eaa03 100644 --- a/src/TAGS +++ b/src/TAGS @@ -16,3 +16,5 @@ cref/TAGS,include rcs/TAGS,include ffi/TAGS,include + +elisp/TAGS,include diff --git a/src/configure.ac b/src/configure.ac index 004413ab2..4c37657ee 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -168,6 +168,7 @@ Makefile compiler/Makefile cref/Makefile edwin/Makefile +elisp/Makefile ffi/Makefile imail/Makefile runtime/Makefile @@ -189,8 +190,8 @@ if test x"${mit_scheme_native_code}" = xc; then 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 $FFIS; do + for BUNDLE in 6001 compiler cref edwin elisp ffi imail sf sos ssp \ + star-parser xdoc xml $FFIS; do SO=${BUNDLE}.so (cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .) done diff --git a/src/elisp/Macros.scm b/src/elisp/Macros.scm index eb570c33a..ff107956a 100644 --- a/src/elisp/Macros.scm +++ b/src/elisp/Macros.scm @@ -23,98 +23,100 @@ USA. ;;;; Scheme Syntax Extensions ;;; package: (elisp syntax-extensions) - -(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. + +(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 diff --git a/src/elisp/Makefile-fragment b/src/elisp/Makefile-fragment new file mode 100644 index 000000000..dec2fcedd --- /dev/null +++ b/src/elisp/Makefile-fragment @@ -0,0 +1,13 @@ +#-*-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)/. diff --git a/src/elisp/Misc.scm b/src/elisp/Misc.scm index 689563af3..6d909e5e2 100644 --- a/src/elisp/Misc.scm +++ b/src/elisp/Misc.scm @@ -306,6 +306,7 @@ NOTE: This variable is not supported by Edwin.") "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)) @@ -336,23 +337,27 @@ NOTE: This variable is not supported by Edwin.") "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 diff --git a/src/elisp/README b/src/elisp/README new file mode 100644 index 000000000..067d7f4c3 --- /dev/null +++ b/src/elisp/README @@ -0,0 +1,85 @@ +-*-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 + Symbol's value as variable is void: \` + + +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. + +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! diff --git a/src/elisp/Subrs.scm b/src/elisp/Subrs.scm index fb420248c..bdf62c764 100644 --- a/src/elisp/Subrs.scm +++ b/src/elisp/Subrs.scm @@ -41,12 +41,12 @@ USA. 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 diff --git a/src/elisp/Symbols.scm b/src/elisp/Symbols.scm index c23b6bb9c..7ad6225aa 100644 --- a/src/elisp/Symbols.scm +++ b/src/elisp/Symbols.scm @@ -59,16 +59,10 @@ USA. ;;; editor variables, its value is kept consistent with the value of the ;;; Emacs symbol. -;; 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" @@ -86,32 +80,15 @@ USA. (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! '())) ;;;; Special bindings stack. @@ -124,7 +101,8 @@ USA. (%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)) @@ -179,7 +157,8 @@ USA. (define +unbound+ "elisp unbound variable tag") (define +not-global+ "elisp non-global variable") -(define-integrable %make-symbol make-%symbol) +(define-integrable (%make-symbol string) + (make-%symbol string)) (declare (integrate-operator ->%symbol)) (define (->%symbol obj) @@ -212,8 +191,7 @@ USA. (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))) @@ -315,6 +293,10 @@ USA. ;; 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) @@ -439,8 +421,7 @@ USA. ;; 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 @@ -450,8 +431,7 @@ USA. (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)) @@ -469,7 +449,7 @@ USA. (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 @@ -522,9 +502,7 @@ USA. (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?) diff --git a/src/elisp/abbrev.scm b/src/elisp/abbrev.scm index e4c4a2ffd..38cb1f82d 100644 --- a/src/elisp/abbrev.scm +++ b/src/elisp/abbrev.scm @@ -210,7 +210,7 @@ Set to nil each time expand-abbrev is called.") 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) diff --git a/src/elisp/buffer.scm b/src/elisp/buffer.scm index 2ae8b894b..f893b1dd2 100644 --- a/src/elisp/buffer.scm +++ b/src/elisp/buffer.scm @@ -151,7 +151,6 @@ If BUFFER is omitted or nil, some interesting buffer is returned." (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 @@ -303,35 +302,21 @@ The R column contains a % for buffers that are read-only." (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 @@ -536,8 +521,6 @@ NOTE: This variable can only be 'fundamental-mode in Edwin." (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. @@ -547,20 +530,19 @@ NOTE: This variable can only be a symbol in Edwin." (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 @@ -586,16 +568,13 @@ NOTE: This variable can only be a boolean in Edwin." 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. @@ -704,7 +683,7 @@ NOTE: This variable can only be a string or nil in Edwin." '())) (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 @@ -719,13 +698,12 @@ Backing up is done before the first time the file is saved. 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")))))) @@ -735,9 +713,10 @@ NOTE: This variable can only be a boolean in Edwin." "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 diff --git a/src/elisp/compile.scm b/src/elisp/compile.scm new file mode 100644 index 000000000..8c417aa4d --- /dev/null +++ b/src/elisp/compile.scm @@ -0,0 +1,29 @@ +#| -*-Scheme-*- |# + +;;;; Compile the ELisp system + +(fluid-let ((load/suppress-loading-message? #t)) + (load-option 'CREF)) + +(fluid-let ((compile-file:sf-only? #t)) + (compile-system + "elisp" (directory-pathname (current-load-pathname)) + 'dependencies + (let* ((deps-edwin (map (lambda (base) (string-append "../edwin/" base)) + '("struct" "comman" "modes" "buffer" "edtstr"))) + (deps-Buffers (cons "Buffers" deps-edwin)) + (deps-Symbols (cons "Symbols" deps-Buffers)) + (deps-all (cons* "lisp" "Subrs" deps-Symbols))) + `(("Buffers" . ,deps-edwin) ;uses lots of Edwin stuff + ("Symbols" . ,deps-Buffers) ;uses Edwin and %current-buffer... + ("Reader" . ,deps-Symbols) ;uses ... and ... and %symbol-*... + ("lisp" . ,deps-Symbols) ;ditto + ;; Assume everything else wants to integrate whatnot from Edwin + ;; and the emulator. Also assume no cross-file integrables + ;; amongst them. + . ,(map (lambda (file) `(,file . ,deps-all)) + '("Misc" + "data" "eval" "fns" "lread" "buffer" "editfns" "fileio" + "alloc" "minibuf" "search" "callint" "syntax" "cmds" "marker" + "window" "keymap" "print" "indent" "process" "dired" "abbrev" + "bytecode")))))) \ No newline at end of file diff --git a/src/elisp/data.scm b/src/elisp/data.scm index e7eb549d2..fd7d7eb3d 100644 --- a/src/elisp/data.scm +++ b/src/elisp/data.scm @@ -273,6 +273,35 @@ USA. (%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) diff --git a/src/elisp/ed-ffi.scm b/src/elisp/ed-ffi.scm new file mode 100644 index 000000000..ac2dd66dc --- /dev/null +++ b/src/elisp/ed-ffi.scm @@ -0,0 +1,36 @@ +#| -*- 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 diff --git a/src/elisp/editfns.scm b/src/elisp/editfns.scm index b58d275fb..d545fc753 100644 --- a/src/elisp/editfns.scm +++ b/src/elisp/editfns.scm @@ -156,7 +156,7 @@ If POS is out of range, the value is NIL." (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. @@ -176,7 +176,7 @@ Differs from user-login-name when running under su." 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." @@ -186,14 +186,7 @@ the pw_gecos field from the /etc/passwd entry." (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))) (DEFUN (el:insert . args) "Any number of args, strings or chars. Insert them after point, moving point diff --git a/src/elisp/elisp.ldr b/src/elisp/elisp.ldr deleted file mode 100644 index 9a999a73a..000000000 --- a/src/elisp/elisp.ldr +++ /dev/null @@ -1,29 +0,0 @@ -#| -*-Scheme-*- - -Not generated by CREF! |# - -(declare (usual-integrations)) - -(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 diff --git a/src/elisp/elisp.pkg b/src/elisp/elisp.pkg index d66158398..bd9c2c9e5 100644 --- a/src/elisp/elisp.pkg +++ b/src/elisp/elisp.pkg @@ -23,100 +23,32 @@ USA. ;;;; ELisp Packaging -(definitions "edwin/edwin") -(definitions "runtime/runtim") +(global-definitions "../runtime/runtime") +(global-definitions "../edwin/edwin") -(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)) - -(define-package (elisp subrs) - (files "Subrs") +(define-package (elisp buffers) + (files "Buffers") (parent (elisp)) (export (elisp) - %subr ;record type, used by inlined %subr? - %subr? - %make-subr - %subr-docstring - %subr-name - %subr-procedure - %subr-prompt - %subr-special-form?)) + elisp-current-buffer ;because %current-buffer is integrated! + %with-current-buffer + %current-buffer + %set-current-buffer! + %save-excursion)) (define-package (elisp symbols) (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! @@ -131,7 +63,11 @@ USA. %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! @@ -158,27 +94,77 @@ USA. Qsetting-constant Qvariable-documentation)) -(define-package (elisp buffers) - (files "Buffers") +(define-package (elisp reader) + (files "Reader") (parent (elisp)) (export (elisp) - elisp-current-buffer ;variable, used by %current-buffer... - %with-current-buffer - %current-buffer - %set-current-buffer! - %save-excursion)) + parse-elisp-object)) -(define-package (elisp syntax-extensions) - (files "Macros") +(define-package (elisp subrs) + (files "Subrs") (parent (elisp)) (export (elisp) - elisp-syntax-table) - (import (runtime syntax-table) - make-syntax-table - syntax-table-define)) + %subr? %%subr? ;because %subr? is integrated! + %make-subr make-%subr ;because %make-subr is integrated! + %subr-docstring + %subr-name + %subr-procedure + %subr-prompt + %subr-special-form?)) -(define-package (elisp reader) - (files "Reader") - (parent (elisp)) - (export (elisp) - parse-elisp-object)) \ No newline at end of file +(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 "lisp" "Macros" "Misc" + "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 diff --git a/src/elisp/elisp.sf b/src/elisp/elisp.sf deleted file mode 100644 index b584e0f91..000000000 --- a/src/elisp/elisp.sf +++ /dev/null @@ -1,88 +0,0 @@ -#| -*-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")))) - -;;; 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 diff --git a/src/elisp/eval.scm b/src/elisp/eval.scm index 4ae7ee5e7..070329f2e 100644 --- a/src/elisp/eval.scm +++ b/src/elisp/eval.scm @@ -380,7 +380,7 @@ definitions to shadow the loaded ones for use in file byte-compilation." (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 @@ -444,7 +444,7 @@ If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway." 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) @@ -540,7 +540,7 @@ Also, a symbol is commandp if its function definition is commandp." (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) @@ -552,7 +552,7 @@ 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 (cddr fun))))) + (if (null? (el:assq Qinteractive (cddr fun))) nil Qt)) ((eq? Qautoload funcar) (eq? Qt (%car (%cdr (%cdr (%cdr fun)))))) (else '()))))))) @@ -778,7 +778,8 @@ Thus, (funcall 'cons 'x 'y) returns (x . y)." ((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) diff --git a/src/elisp/fileio.scm b/src/elisp/fileio.scm index de740a0dd..c23188074 100644 --- a/src/elisp/fileio.scm +++ b/src/elisp/fileio.scm @@ -151,16 +151,21 @@ initial ~ is expanded. See also the function substitute-in-file-name." (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 @@ -625,57 +630,24 @@ If second argument VISIT is non-nil, the buffer's visited filename 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. @@ -698,13 +670,16 @@ If VISIT is neither t nor nil, it means do not print (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) diff --git a/src/elisp/fns.scm b/src/elisp/fns.scm index e4296f1d1..0628f47eb 100644 --- a/src/elisp/fns.scm +++ b/src/elisp/fns.scm @@ -233,7 +233,7 @@ N counts from zero. If LIST is not that long, nil is returned." 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) @@ -244,7 +244,7 @@ The value is actually the element of LIST whose car is ELT." '() (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))))))) @@ -256,7 +256,7 @@ The value is actually the element of LIST whose car is ELT." '() (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))))))) @@ -268,7 +268,7 @@ The value is actually the element of LIST whose cdr is ELT." '() (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))))))) @@ -280,7 +280,7 @@ therefore, write (setq foo (delq element foo)) to be sure of changing foo." (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) @@ -349,8 +349,8 @@ They must have the same data type. 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." @@ -411,40 +411,31 @@ No confirmation of the answer is requested; a single character is enough. 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. @@ -454,24 +445,9 @@ The user must confirm the answer with a newline, and can rub it out if not confi (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 diff --git a/src/elisp/keymap.scm b/src/elisp/keymap.scm index 4d786f487..be0782c06 100644 --- a/src/elisp/keymap.scm +++ b/src/elisp/keymap.scm @@ -27,21 +27,22 @@ USA. #| 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 @@ -164,7 +165,7 @@ definition, and may be any of the above (including another symbol)." (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 "??") @@ -187,14 +188,11 @@ definition, and may be any of the above (including another symbol)." (%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) @@ -380,11 +378,11 @@ so that the KEYS increase in length. The first element is (\"\" . KEYMAP)." 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 @@ -452,7 +450,7 @@ sequence found, rather than a list of all possible key sequences." (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? @@ -601,29 +599,8 @@ an exact match of one of the completions is required.") ;; 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))) @@ -633,18 +610,14 @@ an exact match of one of the completions is required.") (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 ).") +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)))) diff --git a/src/elisp/lisp.scm b/src/elisp/lisp.scm index 5870907eb..d1b1fe664 100644 --- a/src/elisp/lisp.scm +++ b/src/elisp/lisp.scm @@ -24,6 +24,17 @@ USA. ;;;; Fundamental definitions for GNU Emacs Lisp interpreter. ;;; package: (elisp) +(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)) diff --git a/src/elisp/load-up.el b/src/elisp/load-up.el new file mode 100644 index 000000000..e555482da --- /dev/null +++ b/src/elisp/load-up.el @@ -0,0 +1,236 @@ +;;; 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 diff --git a/src/elisp/lread.scm b/src/elisp/lread.scm index aa55a2059..dea1d1400 100644 --- a/src/elisp/lread.scm +++ b/src/elisp/lread.scm @@ -87,7 +87,7 @@ otherwise to default specified in init-load-path of lread.scm.") (continue false)) (lambda () (return (open-input-file filename)))))))) - false))) + '()))) (DEFVAR Qstandard-input Qt @@ -117,7 +117,7 @@ See documentation of read for possible values.") (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 @@ -130,7 +130,7 @@ See documentation of read for possible values.") (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) '())))) @@ -143,11 +143,15 @@ See documentation of read for possible values.") (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 '() diff --git a/src/elisp/make.scm b/src/elisp/make.scm index 6b4cac330..45c27974f 100644 --- a/src/elisp/make.scm +++ b/src/elisp/make.scm @@ -1,6 +1,9 @@ #| -*-Scheme-*- -This file automatically loads the elisp package. |# +Load the Elisp option. |# -(package/system-loader "elisp" '() false) -(in-package (->environment '(elisp)) (load-essential-elisp)) \ No newline at end of file +(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 diff --git a/src/elisp/marker.scm b/src/elisp/marker.scm index 983250256..49d9faa7d 100644 --- a/src/elisp/marker.scm +++ b/src/elisp/marker.scm @@ -58,7 +58,7 @@ BUFFER defaults to the current buffer. 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))) @@ -69,11 +69,11 @@ Returns MARKER." (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)) @@ -81,7 +81,7 @@ Returns 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. diff --git a/src/elisp/minibuf.scm b/src/elisp/minibuf.scm index b1d50a779..516166bda 100644 --- a/src/elisp/minibuf.scm +++ b/src/elisp/minibuf.scm @@ -25,32 +25,35 @@ USA. ;;; 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. |# (DEFUN (el:read-from-minibuffer prompt #!optional initial-input keymap read) "Read a string from the minibuffer, prompting with string PROMPT. @@ -67,12 +70,12 @@ If fourth arg READ is non-nil, then interpret the result as a lisp object (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. @@ -157,8 +160,8 @@ The argument given to PREDICATE is the alist element or the symbol from the obar (%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) @@ -258,44 +261,42 @@ Case is ignored if ambient value of completion-ignore-case is non-nil." (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) - stringmode (%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) stringmode + (%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." @@ -421,16 +422,15 @@ NOTE: help-form is not supported by Edwin.") (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: diff --git a/src/elisp/print.scm b/src/elisp/print.scm index 545141e76..b3df37a27 100644 --- a/src/elisp/print.scm +++ b/src/elisp/print.scm @@ -51,7 +51,7 @@ to get the buffer displayed. It gets one argument, the buffer to display." (%with-current-buffer buffer (lambda () - (set-buffer-writable! buffer) + (set-buffer-writeable! buffer) (el:erase-buffer) (%specbind (list Qstandard-output) diff --git a/src/elisp/process.scm b/src/elisp/process.scm index 62db7947e..7762b5dec 100644 --- a/src/elisp/process.scm +++ b/src/elisp/process.scm @@ -320,10 +320,15 @@ from PROCESS." (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)))) diff --git a/src/elisp/search.scm b/src/elisp/search.scm index e6c12d1ce..e5a069030 100644 --- a/src/elisp/search.scm +++ b/src/elisp/search.scm @@ -55,30 +55,30 @@ If third arg START is non-nil, start search at that index in STRING. 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. @@ -410,19 +410,15 @@ All the elements are normally markers, or nil if the Nth pair didn't match. 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. diff --git a/src/elisp/syntax.scm b/src/elisp/syntax.scm index f9f56c210..3fc4b5bf7 100644 --- a/src/elisp/syntax.scm +++ b/src/elisp/syntax.scm @@ -35,10 +35,10 @@ you must make this variable nil.") (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))) @@ -50,15 +50,12 @@ This is the one specified by the current buffer." (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. @@ -103,7 +100,7 @@ Defined flags are the characters 1, 2, 3 and 4. (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. @@ -122,7 +119,7 @@ and nil is returned." (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) diff --git a/src/elisp/window.scm b/src/elisp/window.scm index 2bd090023..4875ff305 100644 --- a/src/elisp/window.scm +++ b/src/elisp/window.scm @@ -451,17 +451,14 @@ Does not restore the value of point in current buffer." (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 diff --git a/src/etc/compile.scm b/src/etc/compile.scm index 30445eea4..33239da77 100644 --- a/src/etc/compile.scm +++ b/src/etc/compile.scm @@ -38,7 +38,7 @@ USA. (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-ffi dir) (if (eq? microcode-id/compiled-code-type 'C) diff --git a/src/etc/create-makefiles.sh b/src/etc/create-makefiles.sh index 3a4c36608..9b901cebf 100755 --- a/src/etc/create-makefiles.sh +++ b/src/etc/create-makefiles.sh @@ -47,7 +47,8 @@ run_cmd rm -f compiler/machine compiler/compiler.pkg 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 <