--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp buffers) -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Keeps its own notion of the "current" buffer because el:set-buffer must
+change it without affecting the mapping of buffers to windows.
+%call-interactively will set and clear it. |#
+
+(declare (usual-integrations))
+\f
+(define elisp-current-buffer false)
+
+(define (%with-current-buffer buffer thunk)
+ (fluid-let ((elisp-current-buffer buffer))
+ (thunk)))
+
+(define-integrable (%current-buffer)
+ (or elisp-current-buffer
+ ;; For Emacs Lisp being run outside the dynamic extent of a call to
+ ;; %call-interactively.
+ (current-buffer)))
+
+(define-integrable (%set-current-buffer! buffer)
+ (set! elisp-current-buffer buffer))
+
+(define (%save-excursion thunk)
+ (let ((buffer-inside (%current-buffer))
+ (point-inside
+ (mark-right-inserting-copy (buffer-point (%current-buffer))))
+ (mark-inside
+ (mark-right-inserting-copy (buffer-mark (%current-buffer))))
+ (buffer-outside)
+ (point-outside)
+ (mark-outside)
+ (visible-outside?))
+ (dynamic-wind
+ (lambda ()
+ (set! buffer-outside (%current-buffer))
+ (set! point-outside
+ (mark-right-inserting-copy (buffer-point buffer-outside)))
+ (set! mark-outside
+ (mark-right-inserting-copy (buffer-mark buffer-outside)))
+ (set! visible-outside? (eq? buffer-outside (current-buffer)))
+ (%set-current-buffer! buffer-inside)
+ (set-buffer-point! buffer-inside point-inside)
+ (set-buffer-mark! buffer-inside mark-inside)
+ (set! buffer-inside)
+ (set! point-inside)
+ (set! mark-inside)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! buffer-inside (%current-buffer))
+ (set! point-inside
+ (mark-right-inserting-copy (buffer-point buffer-inside)))
+ (set! mark-inside
+ (mark-right-inserting-copy (buffer-mark buffer-inside)))
+ (if (buffer-alive? buffer-outside)
+ (begin
+ (%set-current-buffer! buffer-outside)
+ (set-buffer-point! buffer-outside point-outside)
+ (set-buffer-mark! buffer-outside mark-outside)
+ (if visible-outside? (select-buffer buffer-outside))))
+ (set! buffer-outside)
+ (set! point-outside)
+ (set! mark-outside)
+ (set! visible-outside?)
+ unspecific))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp syntax-extensions) -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Special syntax to help define GNUemacs functions and variables, and
+deal with Emacs' implementation of optional arguments. |#
+
+(declare (usual-integrations))
+\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))))
+
+(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))
+ (error "No set-value! method provided for generic DEFVAR."))
+ (else
+ `((%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.
+
+(syntax-table-define elisp-syntax-table 'UCODE-PRIMITIVE
+ (macro arguments
+ (apply make-primitive-procedure arguments)))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Random things from Emacs Lisp files that haven't been implemented yet.
+
+Some convenient Edwin commands too. |#
+
+(declare (usual-integrations))
+\f
+;;;; keyboard.c
+
+(define elisp-last-command-tag "elisp last command")
+
+(DEFVAR Qthis-command
+ unassigned
+ "The command now being executed.
+The command can set this variable; whatever is put here
+will be in last-command during the following command.
+
+NOTE: In Edwin, this-command is sometimes an Edwin command object."
+ (lambda ()
+ (if (and (pair? *next-message*)
+ (eq? (car *next-message*) elisp-last-command-tag))
+ (cadr *next-message*)
+ (current-command)))
+ (lambda (value)
+ (set-command-message! elisp-last-command-tag value)))
+
+(DEFVAR Qlast-command
+ unassigned
+ "The last command executed. Normally a symbol with a function definition,
+but can be whatever was found in the keymap, or whatever the variable
+`this-command' was set to by that command.
+
+NOTE: In Edwin, last-command is often an Edwin command object."
+ (lambda ()
+ (command-message-receive
+ elisp-last-command-tag
+ identity-procedure
+ (lambda () (last-command))))
+ (lambda (value)
+ (set! *command-message* (list elisp-last-command-tag value))
+ value))
+
+(DEFUN (el:this-command-keys)
+ "Return string of the keystrokes that invoked this command.
+
+NOTE: Commands invoked by function keys will not get the usual
+terminal-specific escape sequences."
+ (let ((key (current-command-key))
+ (convert
+ (lambda (key)
+ (cond ((char? key) (char->string key))
+ ((special-key? key)
+ (string-append "\033["
+ (symbol->string (special-key/symbol key))
+ "~"))
+ (else (error:wrong-type-datum key "an Edwin command key"))))))
+ (if (pair? key)
+ (apply string-append (map convert key))
+ (convert key))))
+
+(DEFVAR Qhelp-form
+ '()
+ "Form to execute when character help-char is read.
+If the form returns a string, that string is displayed.
+If help-form is nil, the help char is not recognized.
+
+NOTE: This variable is not supported by Edwin.")
+
+(DEFUN (el:input-pending-p)
+ "T if command input is currently available with no waiting.
+Actually, the value is NIL only if we can be sure that no input is available."
+ (if (keyboard-peek-no-hang)
+ Qt
+ '()))
+
+
+;;;; dispnew.c
+
+(DEFUN (el:ding #!optional arg)
+ "Beep, or flash the screen.
+Terminates any keyboard macro currently executing unless an argument
+is given."
+ (editor-beep)
+ (if (null? arg) (keyboard-macro-disable))
+ '())
+
+(DEFUN (el:sleep-for n)
+ "Pause, without updating display, for ARG seconds."
+ (let ((n (CHECK-NUMBER n)))
+ (if (positive? n)
+ (sleep-current-thread (* 1000 n))))
+ '())
+
+(DEFUN (el:sit-for n #!optional nodisp)
+ "Perform redisplay, then wait for ARG seconds or until input is available.
+Optional second arg non-nil means don't redisplay.
+Redisplay is preempted as always if input arrives, and does not happen
+if input is available before it starts.
+Value is t if waited the full time with no input arriving."
+ (let ((n (CHECK-NUMBER n))
+ (redisplay? (either-default? nodisp)))
+ (if (keyboard-peek-no-hang)
+ '()
+ (let ((time-limit (+ (real-time-clock) (* 1000 n))))
+ (if redisplay? (update-screens! false))
+ (let loop ()
+ (if (and (if (not (keyboard-peek-no-hang))
+ (begin
+ true)
+ false)
+ (< (real-time-clock) time-limit)
+ (if redisplay? (update-screens! false) true))
+ (loop)))))
+ (if (keyboard-peek-no-hang) '() Qt)))
+
+
+;;;; emacs.c
+
+(DEFVAR Qnoninteractive
+ '()
+ "Non-nil means Emacs is running without interactive terminal.")
+
+(DEFVAR Qsystem-type
+ (%intern (string-downcase microcode-id/operating-system-variant)
+ initial-obarray)
+ "Symbol indicating type of operating system you are using.")
+
+
+;;;; doc.c
+
+(DEFUN (el:substitute-command-keys string)
+ "Return the STRING with substrings of the form \\=\\[COMMAND]
+replaced by either: a keystroke sequence that will invoke COMMAND,
+or \"M-x COMMAND\" if COMMAND is not on any keys.
+Substrings of the form \\=\\{MAPVAR} are replaced by summaries
+\(made by describe-bindings) of the value of MAPVAR, taken as a keymap.
+Substrings of the form \\=\\<MAPVAR> specify to use the value of MAPVAR
+as the keymap for future \\=\\[COMMAND] substrings.
+\\=\\= quotes the following character and is discarded;
+thus, \\=\\=\\=\\= puts \\=\\= into the output, and \\=\\=\\=\\[ puts \\=\\[ into the output."
+ (if (null? string)
+ '()
+ (let ((buffer (%current-buffer))
+ (string (CHECK-STRING string)))
+ (letrec
+ ((comtabs (buffer-comtabs buffer))
+ (end (string-length string))
+ (substitutions
+ (lambda (start*)
+ ;; Return a list of strings that are either the
+ ;; substrings free of special forms, or the
+ ;; substitutions indicated by the special forms.
+ ;; `start*' is where to start scanning in `string'.
+ (let loop ((start start*))
+ (let ((index
+ (substring-find-next-char string start end #\\)))
+ (if (or (not index)
+ (= (1+ index) end))
+ (list (substring string start* end))
+ (let ((next (string-ref string (1+ index))))
+ (cond ((char=? #\[ next)
+ (cons (substring string start* index)
+ (subst-key (+ index 2))))
+ ((char=? #\< next)
+ (cons (substring string start* index)
+ (subst-new-keymap (+ index 2))))
+ ((char=? #\{ next)
+ (cons (substring string start* index)
+ (subst-bindings (+ index 2))))
+ ((char=? #\= next)
+ (cons (substring string start* index)
+ (subst-quote-next (+ index 2))))
+ (else
+ (loop (1+ index))))))))))
+ (subst-key
+ (lambda (start)
+ (let ((index (substring-find-next-char string start end #\])))
+ (if (not index)
+ ;; (GNU Emacs doesn't do this, but I feel I must. :-)
+ (error:%signal
+ Qerror (list "substitute-command-keys: Missing ]"))
+ (cons (let* ((name (substring string start index))
+ (keys (el:where-is-internal
+ (el:intern name)
+ comtabs
+ Qt)))
+ (if (null? keys)
+ (string-append
+ ;;(definition->key-name
+ ;; "execute-extended-elisp-command")
+ "C-M-x"
+ " " name)
+ (el:key-description keys)))
+ (substitutions (1+ index)))))))
+ (subst-new-keymap
+ (lambda (start)
+ (let ((index (substring-find-next-char string start end #\>)))
+ (if (not index)
+ (error:%signal
+ Qerror (list "substitute-command-keys: Missing >"))
+ (let* ((name (substring string start index))
+ (new-comtab (keymap->comtab (el:intern name))))
+ (if new-comtab
+ (begin
+ (set! comtabs (list new-comtab))
+ (substitutions (1+ index)))
+ (begin
+ (set! comtabs '())
+ (cons* "\nUses keymap \"" name
+ "\", which is not currently defined.\n"
+ (substitutions (1+ index))))))))))
+ (subst-bindings
+ (lambda (start)
+ (let ((index (substring-find-next-char string start end #\})))
+ (if (not index)
+ (error:%signal
+ Qerror (list "substitute-command-keys: Missing }"))
+ (let* ((name (substring string start index))
+ (new-comtab (keymap->comtab (el:intern name))))
+ (if new-comtab
+ (cons (with-output-to-string
+ (lambda ()
+ (write-bindings new-comtab
+ (current-output-port))))
+ (substitutions (1+ index)))
+ (cons* "\nUses keymap \""
+ name
+ "\", which is not currently defined.\n"
+ (substitutions (1+ index)))))))))
+ (subst-quote-next
+ (lambda (start)
+ (if (= start end)
+ (list)
+ (let ((next (+ start 1)))
+ (if (char=? #\\ (string-ref string start))
+ (if (= next end)
+ (list "\\")
+ (cons (substring string start (1+ next))
+ (substitutions (1+ next))))
+ (cons (substring string start next)
+ (substitutions next))))))))
+ (apply string-append (substitutions 0))))))
+
+
+;;;; callproc.c
+
+(DEFVAR Qexec-path
+ unassigned
+ "*List of directories to search programs to run in subprocesses.
+Each element is a string (directory name) or nil (try default directory).
+
+NOTE: In Edwin, each element is a pathname or false. The get/set-value
+methods of exec-path will translate from/to the Edwin exec-path. The
+exec-path should not be side-effected without re-setting the symbol value
+afterwards."
+ (lambda ()
+ (map (lambda (elt)
+ (if (not elt)
+ '()
+ (->namestring elt)))
+ (ref-variable exec-path)))
+ (lambda (value)
+ (set-variable! exec-path (map (lambda (elt)
+ (if (null? elt)
+ #f
+ (pathname-as-directory elt)))
+ value))))
+
+
+;;;; loaddefs.el
+
+(DEFVAR Qminor-mode-alist
+ '()
+ "Alist saying how to show minor modes in the mode line.
+Each element looks like (VARIABLE STRING);
+STRING is included in the mode line iff VARIABLE's value is non-nil.
+
+NOTE: This variable is not supported by Edwin.")
+
+
+;;;; convenient access to Emacs Lisp from Edwin
+
+(define-command eval-elisp-expression
+ "Read and evaluate an Emacs Lisp expression in the typein window."
+ "sEvaluate ELisp expression"
+ (lambda (input-string)
+ (with-input-from-string ""
+ (lambda ()
+ (let ((value))
+ (%with-current-buffer
+ (current-buffer)
+ (lambda ()
+ (let ((output-string
+ (with-output-to-string
+ (lambda ()
+ (set! value (el:eval (el:read input-string)))
+ unspecific))))
+ (let ((evaluation-output-receiver
+ (ref-variable evaluation-output-receiver
+ (%current-buffer))))
+ (if evaluation-output-receiver
+ (evaluation-output-receiver value output-string)
+ (with-output-to-transcript-buffer
+ (lambda ()
+ (write-string output-string)
+ (transcript-write
+ value
+ (and (ref-variable enable-transcript-buffer
+ (%current-buffer))
+ (transcript-buffer))))))))))
+ value)))))
+
+(define-command execute-extended-elisp-command
+ "Read an Emacs Lisp command from the terminal with completion and
+invoke it."
+ (lambda ()
+ (list (el:read-command "el:M-x ")))
+ (lambda (command)
+ (%call-interactively (current-buffer) command true)))
+
+
+;;;;
+
+(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.
+ (%with-current-buffer
+ (current-buffer)
+ (lambda ()
+ (fluid-let ((allow-elisp-define-key-overrides? false))
+ (el:load "load-up")))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp reader) -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Implements parse-elisp-object, which takes a port. |#
+
+(declare (usual-integrations))
+\f
+(define char-set/whitespace (ascii-range->char-set #o000 #o041))
+
+(define char-set/non-whitespace (char-set-invert char-set/whitespace))
+
+(define char-set/string-delimiters (char-set #\" #\\))
+
+(define char-set/atom-delimiters
+ (char-set-union char-set/whitespace
+ (char-set #\" #\' #\; #\? #\( #\) #\. #\[ #\] #\# #\\)))
+
+(define char-set/comment-delimiters
+ (char-set #\Newline))
+
+(define (init-parser-table default-handler entries)
+ ;; Creates a vector of 256 elements all initialized to
+ ;; `default-handler', except those indicated by the association list
+ ;; `entries'. `entries' should associate a character or char-set
+ ;; with a handler to which to dispatch. Each handler should be a
+ ;; procedure of zero arguments, operating on *port* and returning
+ ;; a parsed object.
+ (let ((table (make-vector 256 default-handler)))
+ (for-each
+ (lambda (entry)
+ (let loop ()
+ (if (not (or (char-set? (car entry))
+ (char? (car entry))))
+ (begin
+ (error:wrong-type-datum (car entry)
+ "a character or char-set")
+ (loop)))
+ (if (not (and (procedure? (cdr entry))
+ (procedure-arity-valid? (cdr entry) 0)))
+ (begin
+ (error:wrong-type-datum (cdr entry)
+ "a procedure taking zero arguments")
+ (loop))))
+ (cond ((char? (car entry))
+ (vector-set! table (char->ascii (car entry)) (cdr entry)))
+ ((char-set? (car entry))
+ (for-each (lambda (char)
+ (vector-set! table (char->ascii char) (cdr entry)))
+ (char-set-members (car entry)))))
+ unspecific)
+ entries)
+ table))
+\f
+;;;; Top Level
+
+(define (parse-elisp-object port)
+ (fluid-let ((*port* port))
+ (parse-object/dispatch)))
+
+(define (parse-object/dispatch)
+ (let ((ascii (peek-ascii/eof-ok)))
+ (if (eof-object? ascii)
+ ascii
+ ((vector-ref object-parser-table ascii)))))
+
+(define (parse-object/atom)
+ (let ((name
+ (let loop ()
+ (let* ((head (read-string char-set/atom-delimiters))
+ (delimiter (peek-char/eof-ok)))
+ (if (and (not (eof-object? delimiter))
+ (char=? delimiter #\\))
+ (begin
+ (discard-char)
+ ;; GNU Emacs 18.58 treats the EOF as #\M-Rubout!
+ ;; This signals an error.
+ (string-append head (char->string (read-char)) (loop)))
+ head)))))
+ (or (string->number name 10)
+ (%intern name (%symbol-value Qobarray)))))
+
+(define (parse-object/list-open)
+ ;; Called when an open paren is seen at "top" level.
+ (discard-char)
+ (collect-list/first))
+
+(define (parse-object/invalid-char)
+ (error:%signal Qinvalid-read-syntax (list (char->string (read-char)))))
+
+(define (parse-object/vector-open)
+ ;; Called when an open square bracket is seen at "top" level.
+ (discard-char)
+ (list->vector (collect-vector/dispatch)))
+
+(define (parse-object/comment)
+ (discard-comment)
+ (parse-object/dispatch))
+
+(define (parse-object/quote)
+ (discard-char)
+ (list Qquote (parse-object/dispatch)))
+
+(define-integrable (invalid-escape-character-syntax)
+ (error:%signal Qerror (list "Invalid escape character syntax")))
+
+(define (parse-object/char-quote)
+ (discard-char)
+ (let ((ascii (read-ascii/eof-ok)))
+ (if (and (not (eof-object? ascii))
+ (fix:= ascii (char->ascii #\\)))
+ (let ((ascii (read-escape)))
+ (if (fix:= ascii -1)
+ ;; GNU Emacs 18.58 produces -1! This signals an error.
+ (invalid-escape-character-syntax)
+ ascii))
+ ascii)))
+
+(define (parse-object/string-quote)
+ (discard-char)
+ (let loop ()
+ (let ((head (read-string char-set/string-delimiters)))
+ (if (eof-object? head)
+ ;; GNU Emacs 18.58 produces ""! This signals an error.
+ (error:%signal Qend-of-file '())
+ (let ((delimiter (read-char)))
+ (if (char=? delimiter #\")
+ (if (let ((next (peek-char/eof-ok)))
+ (and (not (eof-object? next))
+ (char=? next #\")))
+ (begin
+ (read-char)
+ (string-append head "\"" (loop)))
+ ;; done!
+ head)
+ ;; char was #\\
+ (let ((ascii (read-escape)))
+ (string-append head
+ (if (fix:= ascii -1)
+ ""
+ (char->string (ascii->char ascii)))
+ (loop)))))))))
+
+(define (read-escape)
+ ;; Called when a backslash has been read in a string or char-quote.
+ ;; Return ascii integer for character described by GNU Emacs escape syntax.
+ ;; Or -1 for \<newline>.
+ (declare (integrate-operator char->ascii))
+ (let ((char (read-char/eof-ok)))
+ (if (eof-object? char)
+ ;; GNU Emacs 18.58 produces 255. This signals an error.
+ (error:%signal Qend-of-file '())
+ (case char
+ ((#\a) (char->ascii #\BEL))
+ ((#\b) (char->ascii #\BS))
+ ((#\e) (char->ascii #\ESC))
+ ((#\f) (char->ascii #\FF))
+ ((#\n) (char->ascii #\LF))
+ ((#\r) (char->ascii #\CR))
+ ((#\t) (char->ascii #\HT))
+ ((#\v) (char->ascii #\VT))
+ ((#\newline) -1)
+ ((#\M)
+ (if (not (char=? (read-char) #\-))
+ (invalid-escape-character-syntax)
+ (let ((ascii (let ((ascii (read-ascii)))
+ (if (fix:= ascii (char->ascii #\\))
+ (read-escape)
+ ascii))))
+ (if (fix:= ascii -1)
+ (invalid-escape-character-syntax)
+ (fix:or #o200 ascii)))))
+ ((#\C #\^)
+ (if (and (char=? char #\C)
+ (not (char=? (read-char) #\-)))
+ (invalid-escape-character-syntax)
+ (let ((ascii (let ((ascii (read-ascii)))
+ (if (fix:= ascii (char->ascii #\\))
+ (read-escape)
+ ascii))))
+ (if (fix:= ascii -1)
+ (invalid-escape-character-syntax)
+ (fix:or (fix:and #o200 ascii)
+ (fix:and #o037 ascii))))))
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
+ (let loop ((i (char->digit char 8))
+ (count 1))
+ (if (and (< count 3)
+ (let ((ascii (peek-ascii)))
+ (and (fix:<= (char->ascii #\0) ascii)
+ (fix:<= ascii (char->ascii #\7)))))
+ (loop (+ (* i 8) (char->digit (read-char) 8)) (1+ count))
+ i)))
+ (else
+ ;; This only works because the meta bit is the eighth bit!
+ (char->ascii char))))))
+
+(define (parse-object/whitespace)
+ (discard-whitespace)
+ (parse-object/dispatch))
+
+(define object-parser-table
+ (init-parser-table
+ parse-object/atom
+ `((#\( . ,parse-object/list-open)
+ (#\) . ,parse-object/invalid-char)
+ (#\[ . ,parse-object/vector-open)
+ (#\] . ,parse-object/invalid-char)
+ (#\; . ,parse-object/comment)
+ (#\' . ,parse-object/quote)
+ (#\? . ,parse-object/char-quote)
+ (#\" . ,parse-object/string-quote)
+ (,char-set/whitespace . ,parse-object/whitespace)
+ (#\. . ,parse-object/invalid-char)
+ (#\# . ,parse-object/invalid-char))))
+\f
+;;;; Lists
+
+(define (collect-list/first)
+ ;; Collect a list, but make sure it doesn't start with a dot.
+ (let ((value (collect-list/dispatch)))
+ (if (or (null? value) (pair? value))
+ value
+ ;; Given: (read-from-string "( . a)")
+ ;; GNU Emacs 18.58 produces (a . 6)! This signals an error.
+ (error:%signal Qinvalid-read-syntax (list ". in wrong context")))))
+
+(define-integrable (collect-list/dispatch)
+ ((vector-ref list-parser-table (peek-ascii))))
+
+(define ((collect-list/wrapper parse-it))
+ ;; Parse-it and add it to the list currently being collected.
+ (let* ((first (parse-it))
+ (rest (collect-list/dispatch)))
+ (cons first rest)))
+
+(define (collect-list/dot)
+ (discard-char)
+ (let ((rest (collect-list/dispatch)))
+ (if (and (pair? rest)
+ (null? (cdr rest)))
+ (car rest)
+ (error:%signal Qinvalid-read-syntax (list ". in wrong context")))))
+
+(define (collect-stuff/done)
+ ;; Called when close paren seen while parsing a list.
+ (discard-char)
+ (list))
+
+(define (collect-list/vector-close)
+ ;; Called when close square bracket seen while parsing a list.
+ (error:%signal Qinvalid-read-syntax (list "] in a list")))
+
+(define (collect-list/comment)
+ (discard-comment)
+ (collect-list/dispatch))
+
+(define (collect-list/whitespace)
+ (discard-whitespace)
+ (collect-list/dispatch))
+
+(define list-parser-table
+ (init-parser-table
+ (collect-list/wrapper parse-object/atom)
+ `((#\( . ,(collect-list/wrapper parse-object/list-open))
+ (#\[ . ,(collect-list/wrapper parse-object/vector-open))
+ (#\. . ,collect-list/dot)
+ (#\) . ,collect-stuff/done)
+ (#\] . ,collect-list/vector-close)
+ (#\; . ,collect-list/comment)
+ (#\' . ,(collect-list/wrapper parse-object/quote))
+ (#\? . ,(collect-list/wrapper parse-object/char-quote))
+ (#\" . ,(collect-list/wrapper parse-object/string-quote))
+ (,char-set/whitespace . ,collect-list/whitespace))))
+\f
+;;;; Vectors
+
+(define (collect-vector/dispatch)
+ ((vector-ref vector-parser-table (peek-ascii))))
+
+(define ((collect-vector/wrapper parse-it))
+ ;; Parse-it and add it to the list of vector elements currently being
+ ;; collected.
+ (let* ((first (parse-it))
+ (rest (collect-vector/dispatch)))
+ (cons first rest)))
+
+(define (collect-vector/list-syntax)
+ (discard-char)
+ (error:%signal Qinvalid-read-syntax (list ") or . in a vector")))
+
+(define (collect-vector/comment)
+ (discard-comment)
+ (collect-vector/dispatch))
+
+(define (collect-vector/whitespace)
+ (discard-whitespace)
+ (collect-vector/dispatch))
+
+(define vector-parser-table
+ (init-parser-table
+ (collect-vector/wrapper parse-object/atom)
+ `((#\( . ,(collect-vector/wrapper parse-object/list-open))
+ (#\[ . ,(collect-vector/wrapper parse-object/vector-open))
+ (#\. . ,collect-vector/list-syntax)
+ (#\) . ,collect-vector/list-syntax)
+ (#\] . ,collect-stuff/done)
+ (#\; . ,collect-vector/comment)
+ (#\' . ,(collect-vector/wrapper parse-object/quote))
+ (#\? . ,(collect-vector/wrapper parse-object/char-quote))
+ (#\" . ,(collect-vector/wrapper parse-object/string-quote))
+ (,char-set/whitespace . ,collect-vector/whitespace))))
+\f
+;;;; Character Operations
+
+(define *port*)
+
+(define (peek-char/eof-ok)
+ (let loop ()
+ (or (input-port/peek-char *port*)
+ (loop))))
+
+(define (peek-char)
+ (let ((char (peek-char/eof-ok)))
+ (if (eof-object? char)
+ (error:%signal Qend-of-file '())
+ char)))
+
+(define-integrable (read-char/eof-ok)
+ (let loop ()
+ (or (input-port/read-char *port*)
+ (loop))))
+
+(define (read-char)
+ (let ((char (read-char/eof-ok)))
+ (if (eof-object? char)
+ (error:%signal Qend-of-file '())
+ char)))
+
+(define (peek-ascii/eof-ok)
+ (let ((char (peek-char/eof-ok)))
+ (cond ((eof-object? char) char)
+ ((char-ascii? char) (char->ascii char))
+ (else
+ (error:%signal Qerror
+ (list "Non-ASCII character encountered" char))))))
+
+(define (peek-ascii)
+ (let ((char (peek-char)))
+ (if (char-ascii? char)
+ (char->ascii char)
+ (error:%signal Qerror (list "Non-ASCII character encountered" char)))))
+
+(define (read-ascii/eof-ok)
+ (let ((char (read-char/eof-ok)))
+ (cond ((eof-object? char) char)
+ ((char-ascii? char) (char->ascii char))
+ (else
+ (error:%signal Qerror
+ (list "Non-ASCII character encountered" char))))))
+
+(define (read-ascii)
+ (let ((char (read-char)))
+ (if (char-ascii? char)
+ (char->ascii char)
+ (error:%signal Qerror (list "Non-ASCII character encountered" char)))))
+
+(define-integrable (discard-char)
+ (input-port/discard-char *port*))
+
+(define (read-string delimiters)
+ (input-port/read-string *port* delimiters))
+
+(define-integrable (discard-chars delimiters)
+ (input-port/discard-chars *port* delimiters))
+
+(define (discard-whitespace)
+ (discard-chars char-set/non-whitespace))
+
+(define (discard-comment)
+ (discard-char)
+ (discard-chars char-set/comment-delimiters)
+ (discard-char))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp subrs) -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Subrs are simple structures carrying an Emacs primitive's docstring,
+interactive spec (if any), the Scheme procedure implementing the
+primitive, and a note to the Emacs Lisp interpreter about whether
+arguments should be evaluated or not. The structure is wrapped in an
+apply hook to make the Subr callable from Edwin Scheme as well as Emacs
+Lisp. |#
+
+(declare (usual-integrations))
+\f
+(define %subr
+ (make-record-type
+ "%subr"
+ '(NAME ; To print like a real Emacs subr...
+ PROCEDURE ; Same as apply hook's procedure.
+ DOCSTRING
+ PROMPT
+ SPECIAL-FORM?)))
+
+(set-record-type-unparser-method!
+ %subr
+ (lambda (state object)
+ ((unparser/standard-method "el:subr") state object)))
+
+(define %subr?
+ (let ((%%subr? (record-predicate %subr)))
+ (lambda (obj)
+ (and (apply-hook? obj) (%%subr? (apply-hook-extra obj))))))
+
+(define %make-subr
+ (let ((constructor (record-constructor
+ %subr '(NAME PROCEDURE DOCSTRING PROMPT SPECIAL-FORM?))))
+ (lambda (name procedure docstring prompt special-form?)
+ (make-apply-hook
+ procedure
+ (constructor name procedure docstring prompt special-form?)))))
+
+(define (%subr-accessor field)
+ (let ((getit (record-accessor %subr field)))
+ (lambda (obj) (getit (apply-hook-extra obj)))))
+
+(define %subr-name (%subr-accessor 'NAME))
+
+(define %subr-procedure (%subr-accessor 'PROCEDURE))
+
+(define %subr-docstring (%subr-accessor 'DOCSTRING))
+
+(define %subr-prompt (%subr-accessor 'PROMPT))
+
+(define %subr-special-form? (%subr-accessor 'SPECIAL-FORM?))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp symbols) -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Emacs Lisp symbols are implemented by an object that holds the
+dynamically-scoped value, the function, and the property list of the
+symbol. Operations on the object include getting and setting its
+value, getting and setting its default value, etc. An Emacs Lisp
+symbol usually has one global value; operations on it just access
+or modify a Scheme variable. An Emacs Lisp symbol can also take on
+buffer-specific values. When this happens, an Edwin editor variable
+with the same name is found or created; the operations of the Emacs
+Lisp symbol access or modify the buffer-specific value, default value,
+and other attributes of the Edwin editor variable.
+
+The operations of the Emacs Lisp symbol are implemented by procedures
+assigned to the fields of the symbol object. The global value, or
+editor variable, is assigned to Scheme variables closed over by these
+procedures.
+
+An Emacs Lisp symbol can also be given arbitrary procedures that
+implement the operations for getting and setting the symbol's value.
+These procedures can be used to get a value from an Edwin data
+structure and convert it to the type expected by Emacs.
+
+An Emacs Lisp symbol will find or create a similarly named Edwin
+editor variable when buffer-specific behavior is required by a call to
+`el:make-variable-buffer-local' or `el:make-local-variable'. An Edwin
+editor variable is also used when the symbol is declared to be a
+variable or constant by `el:defvar' or `el:defconst'. This allows the
+Emacs variable to be examined and set using the usual Edwin commands.
+Once an Emacs Lisp symbol arranges to use an Edwin variable, it always
+uses that variable. Even if the symbol is made unassigned (by
+`el:makunbound'), the Edwin variable continues to be used. Any
+buffer-local values of the variable are removed, and it is made no
+longer buffer-local. Thus, once it appears in the list of Edwin's
+editor variables, its value is kept consistent with the value of the
+Emacs symbol. |#
+
+(declare (usual-integrations))
+\f
+(define %symbol-rt
+ (make-record-type
+ "el:symbol"
+ '(NAME
+ FUNCTION
+ PLIST
+ ;; For chaining together contents of obarray buckets.
+ NEXT
+ ;; An Edwin command created to reflect an Emacs command named by
+ ;; this symbol.
+ COMMAND
+ ;; Methods...
+ BOUND?
+ UNBOUND!
+ GET-VALUE
+ SET-VALUE!
+ GET-DEFAULT
+ SET-DEFAULT!
+ MAKE-LOCAL!
+ MAKE-ALL-LOCAL!
+ KILL-LOCAL!
+ SET-DOCSTRING!)))
+
+(define-integrable %%symbol?
+ (record-predicate %symbol-rt))
+(define-integrable %symbol/name
+ (record-accessor %symbol-rt 'NAME))
+(define-integrable %symbol/function
+ (record-accessor %symbol-rt 'FUNCTION))
+(define-integrable set-%symbol/function!
+ (record-modifier %symbol-rt 'FUNCTION))
+(define-integrable %symbol/plist
+ (record-accessor %symbol-rt 'PLIST))
+(define-integrable set-%symbol/plist!
+ (record-modifier %symbol-rt 'PLIST))
+(define-integrable %symbol/next
+ (record-accessor %symbol-rt 'NEXT))
+(define-integrable set-%symbol/next!
+ (record-modifier %symbol-rt 'NEXT))
+(define-integrable %symbol/command
+ (record-accessor %symbol-rt 'COMMAND))
+(define-integrable set-%symbol/command!
+ (record-modifier %symbol-rt 'COMMAND))
+(define-integrable %symbol/bound?
+ (record-accessor %symbol-rt 'BOUND?))
+(define-integrable set-%symbol/bound?!
+ (record-modifier %symbol-rt 'BOUND?))
+(define-integrable %symbol/unbound!
+ (record-accessor %symbol-rt 'UNBOUND!))
+(define-integrable set-%symbol/unbound!!
+ (record-modifier %symbol-rt 'UNBOUND!))
+(define-integrable %symbol/get-value
+ (record-accessor %symbol-rt 'GET-VALUE))
+(define-integrable set-%symbol/get-value!
+ (record-modifier %symbol-rt 'GET-VALUE))
+(define-integrable %symbol/set-value!
+ (record-accessor %symbol-rt 'SET-VALUE!))
+(define-integrable set-%symbol/set-value!!
+ (record-modifier %symbol-rt 'SET-VALUE!))
+(define-integrable %symbol/get-default
+ (record-accessor %symbol-rt 'GET-DEFAULT))
+(define-integrable set-%symbol/get-default!
+ (record-modifier %symbol-rt 'GET-DEFAULT))
+(define-integrable %symbol/set-default!
+ (record-accessor %symbol-rt 'SET-DEFAULT!))
+(define-integrable set-%symbol/set-default!!
+ (record-modifier %symbol-rt 'SET-DEFAULT!))
+(define-integrable %symbol/make-local!
+ (record-accessor %symbol-rt 'MAKE-LOCAL!))
+(define-integrable set-%symbol/make-local!!
+ (record-modifier %symbol-rt 'MAKE-LOCAL!))
+(define-integrable %symbol/make-all-local!
+ (record-accessor %symbol-rt 'MAKE-ALL-LOCAL!))
+(define-integrable set-%symbol/make-all-local!!
+ (record-modifier %symbol-rt 'MAKE-ALL-LOCAL!))
+(define-integrable %symbol/kill-local!
+ (record-accessor %symbol-rt 'KILL-LOCAL!))
+(define-integrable set-%symbol/kill-local!!
+ (record-modifier %symbol-rt 'KILL-LOCAL!))
+(define-integrable %symbol/set-docstring!
+ (record-accessor %symbol-rt 'SET-DOCSTRING!))
+(define-integrable set-%symbol/set-docstring!!
+ (record-modifier %symbol-rt 'SET-DOCSTRING!))
+
+(set-record-type-unparser-method!
+ %symbol-rt
+ (lambda (state object)
+ ((unparser/standard-method "el:symbol"
+ (lambda (state object)
+ (write-string (%symbol/name object)
+ (unparser-state/port state))))
+ state object)))
+\f
+;;;; Exported definitions
+
+(define (%symbol? obj)
+ (or (null? obj)
+ (%%symbol? obj)))
+
+(define +unbound+ "elisp unbound variable tag")
+
+(define %make-symbol
+ (let ((constructor
+ (record-constructor %symbol-rt
+ '(NAME FUNCTION PLIST NEXT COMMAND BOUND?))))
+ (lambda (name)
+ (let ((symbol
+ (constructor name +unbound+ '() '() false false-procedure)))
+ ;; Don't make variable just because there's an Edwin variable with
+ ;; the same name. Otherwise, things could get dicey with multiple
+ ;; symbols with the same name -- e.g. an abbrev with the same name
+ ;; as an editor variable.
+ (%make-symbol-global! symbol)
+ symbol))))
+
+(declare (integrate-operator ->%symbol))
+(define (->%symbol obj)
+ (if (null? obj)
+ ;; No type-checking here. `obj' should have been checked by subr!
+ Qnil
+ obj))
+
+(declare (integrate-operator %symbol->))
+(define (%symbol-> obj)
+ (if (eq? Qnil obj)
+ '()
+ obj))
+
+(define (%symbol-name symbol)
+ (%symbol/name (->%symbol symbol)))
+
+(define (%symbol-function sym)
+ (let ((fun (%symbol/function (->%symbol sym))))
+ (if (eq? +unbound+ fun)
+ (error:%signal Qvoid-function (list sym))
+ fun)))
+
+(define (%set-symbol-function! sym function)
+ (set-%symbol/function! (->%symbol sym) function))
+
+(define (%symbol-fbound? sym)
+ (let ((fun (%symbol/function (->%symbol sym))))
+ (not (eq? +unbound+ fun))))
+
+(define (%set-symbol-funbound! sym)
+ (set-%symbol/function! (->%symbol sym) +unbound+)
+ unspecific)
+
+(define (%symbol-plist sym)
+ (%symbol/plist (->%symbol sym)))
+
+(define (%set-symbol-plist! sym val)
+ (set-%symbol/plist! (->%symbol sym) val))
+
+(define (%get symbol property)
+ (let loop ((plist (%symbol-plist symbol)))
+ (cond ((null? plist) '())
+ ((not (pair? plist))
+ (loop (wrong-type-argument Qlistp plist)))
+ ((not (pair? (cdr plist)))
+ (set-cdr! plist (wrong-type-argument Qlistp (cdr plist)))
+ (loop plist))
+ ((eq? property (car plist))
+ (car (cdr plist)))
+ (else (loop (cdr (cdr plist)))))))
+
+(define (%put! symbol property value)
+ (let ((symbol (->%symbol symbol)))
+ (if (eq? property Qvariable-documentation)
+ ((%symbol/set-docstring! symbol) value))
+ (let loop ((plist (%symbol/plist symbol)))
+ (cond ((null? plist)
+ (%set-symbol-plist!
+ symbol (cons property (cons value (%symbol/plist symbol)))))
+ ((not (pair? plist))
+ (loop (wrong-type-argument Qlistp plist)))
+ ((not (pair? (cdr plist)))
+ (set-cdr! plist (wrong-type-argument Qlistp (cdr plist)))
+ (loop plist))
+ ((eq? property (car plist))
+ (set-car! (cdr plist) value))
+ (else (loop (cdr (cdr plist)))))))
+ value)
+
+(define (%symbol-command sym)
+ (%symbol/command (->%symbol sym)))
+
+(define (%set-symbol-command! sym com)
+ (set-%symbol/command! (->%symbol sym) com))
+
+(define-integrable (%symbol-bound? symbol)
+ ((%symbol/bound? (->%symbol symbol))))
+
+(define-integrable (%set-symbol-unbound! symbol)
+ ((%symbol/unbound! (->%symbol symbol))))
+
+(define-integrable (%symbol-value symbol)
+ ((%symbol/get-value (->%symbol symbol))))
+
+(define-integrable (%set-symbol-value! symbol value)
+ ((%symbol/set-value! (->%symbol symbol)) value))
+
+(define-integrable (%symbol-default symbol)
+ ((%symbol/get-default (->%symbol symbol))))
+
+(define-integrable (%set-symbol-default! symbol value)
+ ((%symbol/set-default! (->%symbol symbol)) value))
+
+(define-integrable (%make-variable-buffer-local! symbol)
+ ((%symbol/make-all-local! (->%symbol symbol))))
+
+(define-integrable (%make-local-variable! symbol)
+ ((%symbol/make-local! (->%symbol symbol))))
+
+(define-integrable (%kill-local-variable! symbol)
+ ((%symbol/kill-local! (->%symbol symbol))))
+\f
+;;;; Obarrays
+
+(define initial-obarray (make-vector 511 0))
+
+(define (%intern string obarray)
+ (let ((sym (%%intern string obarray
+ (string-hash-mod string (vector-length obarray)))))
+ (if (eq? sym Qnil)
+ '()
+ sym)))
+
+(define (%intern-soft string obarray)
+ (let ((sym (%%intern-soft string obarray
+ (string-hash-mod string (vector-length obarray)))))
+ (if (eq? sym Qnil)
+ '()
+ sym)))
+
+(define (%%intern string obarray hash)
+ (let ((existing-symbol (%%intern-soft string obarray hash)))
+ (if (not existing-symbol)
+ (let ((datum (%make-symbol string))
+ (next (let ((bucket (vector-ref obarray hash)))
+ (cond ((and (integer? bucket) (zero? bucket)) '())
+ ((%%symbol? bucket) bucket)
+ (else (error:%signal
+ Qerror
+ (list "Bad data in obarray")))))))
+ (set-%symbol/next! datum next)
+ (vector-set! obarray hash datum)
+ datum)
+ existing-symbol)))
+
+(define (%%intern-soft string obarray hash)
+ ;; Returns false if there is no existing symbol named by `string' in
+ ;; `obarray'.
+ (let ((bucket (vector-ref obarray hash)))
+ (cond ((and (integer? bucket) (zero? bucket)) false)
+ ((%%symbol? bucket)
+ (let loop ((sym bucket))
+ (cond ((null? sym) false)
+ ((not (%%symbol? sym))
+ (error "Bad data in guts of obarray")
+ (%%intern-soft string obarray hash))
+ ((string=? string (%symbol/name sym)) sym)
+ (else (loop (%symbol/next sym))))))
+ (else
+ (error:%signal Qerror (list "Bad data in obarray"))))))
+
+(define (%for-symbol receiver obarray)
+ (let ((length (vector-length obarray)))
+ (let ob-loop ((idx 0))
+ (and (< idx length)
+ (let bucket-loop ((sym (vector-ref obarray idx)))
+ (if (%%symbol? sym)
+ (begin
+ (if (eq? sym Qnil)
+ (receiver '())
+ (receiver sym))
+ (bucket-loop (%symbol/next sym)))
+ (ob-loop (1+ idx)))))))
+ unspecific)
+\f
+;;;; Coercion procedures.
+
+(define (%make-symbol-global! symbol)
+ (let* ((bound? (%symbol-bound? symbol))
+ (value (if bound? (%symbol-default symbol) '())))
+ (let ((bound?
+ (lambda ()
+ bound?))
+ (unbound!
+ (lambda ()
+ (set! bound? false)
+ unspecific))
+ (get-value
+ (lambda ()
+ (if bound?
+ value
+ (error:%signal Qvoid-variable (list (%symbol-> symbol))))))
+ (set-value!
+ (lambda (new-value)
+ (set! bound? true)
+ (set! value new-value)
+ unspecific))
+ (make-local!
+ (lambda ()
+ (%make-symbol-variable! symbol)
+ ((%symbol/make-local! symbol))
+ unspecific))
+ (make-all-local!
+ (lambda ()
+ (%make-symbol-variable! symbol)
+ ((%symbol/make-all-local! symbol))
+ unspecific))
+ (kill-local!
+ (lambda ()
+ unspecific))
+ (set-docstring!
+ (lambda (string)
+ string
+ unspecific)))
+ (set-%symbol/bound?! symbol bound?)
+ (set-%symbol/unbound!! symbol unbound!)
+ (set-%symbol/get-value! symbol get-value)
+ (set-%symbol/set-value!! symbol set-value!)
+ (set-%symbol/get-default! symbol get-value)
+ (set-%symbol/set-default!! symbol set-value!)
+ (set-%symbol/make-local!! symbol make-local!)
+ (set-%symbol/make-all-local!! symbol make-all-local!)
+ (set-%symbol/kill-local!! symbol kill-local!)
+ (set-%symbol/set-docstring!! symbol set-docstring!)
+ unspecific)))
+
+(define (%make-symbol-variable! symbol)
+ (let* ((existing-variable
+ (string-table-get editor-variables (%symbol-name symbol)))
+ (bound? (or (%symbol-bound? symbol)
+ existing-variable))
+ (edwin-variable
+ ;; Find or create an Edwin variable with SYMBOL's name. Set the
+ ;; Edwin variable attributes to match existing attributes of
+ ;; SYMBOL, if any. Preserve attributes of Edwin variable, if
+ ;; any.
+ (let ((docstring
+ (if existing-variable
+ (vector-ref existing-variable
+ variable-index:description)
+ (%get symbol Qvariable-documentation)))
+ (default
+ (cond (existing-variable
+ (variable-default-value existing-variable))
+ ((%symbol-bound? symbol) (%symbol-value symbol))
+ (else '()))))
+ (if existing-variable
+ (begin
+ (if docstring
+ (vector-set! existing-variable
+ variable-index:description docstring))
+ (set-variable-default-value! existing-variable default)
+ existing-variable)
+ (make-variable (intern (%symbol-name symbol))
+ (or docstring
+ ;; describe-variable doesn't like
+ ;; false documentation strings!
+ "undocumented emacs lisp variable")
+ default false)))))
+ (let ((bound?
+ (lambda ()
+ (if (and bound? existing-variable) 'EDWIN bound?)))
+ (unbound!
+ (lambda ()
+ (set-variable-default-value! edwin-variable false)
+ (map (lambda (buffer)
+ (undefine-variable-local-value! buffer edwin-variable))
+ (buffer-list))
+ (vector-set! edwin-variable variable-index:buffer-local? false)
+ (set! bound? false)
+ unspecific))
+ (get-value
+ (lambda ()
+ (let ((value
+ (if bound?
+ (if (buffer-local-bindings-installed?
+ (%current-buffer))
+ (variable-value edwin-variable) ; use cached value!
+ (variable-local-value
+ (%current-buffer) edwin-variable))
+ (error:%signal Qvoid-variable
+ (list (%symbol-> symbol))))))
+ (if (eq? value #t)
+ Qt
+ value))))
+ (set-value!
+ (lambda (new-value)
+ (set! bound? true)
+ (set-variable-local-value! (%current-buffer) edwin-variable
+ (if (eq? new-value Qt)
+ #t
+ new-value))
+ unspecific))
+ (get-default
+ (lambda ()
+ (if bound?
+ (variable-default-value edwin-variable)
+ (error:%signal Qvoid-variable (list (%symbol-> symbol))))))
+ (set-default!
+ (lambda (default-value)
+ (set! bound? true)
+ (set-variable-default-value! edwin-variable default-value)
+ unspecific))
+ (make-local!
+ (lambda ()
+ (define-variable-local-value!
+ (%current-buffer)
+ edwin-variable (variable-value edwin-variable))
+ unspecific))
+ (make-all-local!
+ (lambda ()
+ (make-variable-buffer-local! edwin-variable)
+ unspecific))
+ (kill-local!
+ (lambda ()
+ (undefine-variable-local-value! (%current-buffer)
+ edwin-variable)
+ unspecific))
+ (set-docstring!
+ (lambda (docstring)
+ (if (not existing-variable)
+ (vector-set! edwin-variable
+ variable-index:description
+ docstring))
+ unspecific)))
+ (set-%symbol/bound?! symbol bound?)
+ (set-%symbol/unbound!! symbol unbound!)
+ (set-%symbol/get-value! symbol get-value)
+ (set-%symbol/set-value!! symbol set-value!)
+ (set-%symbol/get-default! symbol get-default)
+ (set-%symbol/set-default!! symbol set-default!)
+ (set-%symbol/make-local!! symbol make-local!)
+ (set-%symbol/make-all-local!! symbol make-all-local!)
+ (set-%symbol/kill-local!! symbol kill-local!)
+ (set-%symbol/set-docstring!! symbol set-docstring!))))
+
+(define (%make-symbol-generic! symbol get-value set-value!)
+ (set-%symbol/bound?! symbol true-procedure)
+ (set-%symbol/unbound!! symbol false-procedure)
+ (set-%symbol/get-value! symbol get-value)
+ (set-%symbol/set-value!! symbol set-value!)
+ (set-%symbol/get-default! symbol get-value)
+ (set-%symbol/set-default!! symbol set-value!)
+ (set-%symbol/make-local!! symbol false-procedure)
+ (set-%symbol/make-all-local!! symbol false-procedure)
+ (set-%symbol/kill-local!! symbol false-procedure)
+ (set-%symbol/set-docstring!! symbol false-procedure)
+ unspecific)
+
+(define ((boolean-getter edwin-variable))
+ (if (variable-local-value (%current-buffer) edwin-variable)
+ Qt
+ '()))
+
+(define ((boolean-setter edwin-variable) value)
+ (set-variable-local-value!
+ (%current-buffer)
+ edwin-variable
+ (cond ((eq? value Qt) true)
+ ((null? value) false)
+ ;; Let Edwin signal the error!
+ (else value))))
+
+(define ((boolean-default-getter edwin-variable))
+ (if (variable-default-value edwin-variable)
+ Qt
+ '()))
+
+(define ((boolean-default-setter edwin-variable) value)
+ (set-variable-default-value!
+ edwin-variable
+ ;; (not (null? value))
+ (cond ((eq? value Qt) true)
+ ((null? value) false)
+ ;; Let Edwin signal the error.
+ (else value))))
+
+(define ((default-getter edwin-variable))
+ (variable-default-value edwin-variable))
+
+(define ((default-setter edwin-variable) value)
+ (set-variable-default-value! edwin-variable value))
+
+(define ((constant-getter constant))
+ constant)
+
+(define ((constant-setter symbol constant description) value)
+ (if (not (eq? value constant))
+ (editor-error "Setting "
+ (%symbol-name symbol)
+ " to anything other than "
+ description
+ " is not supported in Edwin (yet).")))
+
+(define ((unimplemented-getter symbol))
+ (editor-error "unimplemented elisp variable" symbol))
+
+(define ((unimplemented-setter symbol) value)
+ value
+ (editor-error "unimplemented elisp variable" symbol))
+\f
+;;;; Initializing some symbols.
+
+;; This is a stand-in for '() when symbol operations are applied.
+(define Qnil
+ (let ((Qnil (%%intern "nil" initial-obarray
+ (string-hash-mod "nil"
+ (vector-length initial-obarray)))))
+ ((%symbol/set-value! Qnil) '())
+ (set-%symbol/unbound!!
+ Qnil (lambda (val) val (error:%signal Qsetting-constant (list '()))))
+ (set-%symbol/set-value!!
+ Qnil (lambda (val) val (error:%signal Qsetting-constant (list '()))))
+ (set-%symbol/set-default!!
+ Qnil (lambda (val) val (error:%signal Qsetting-constant (list '()))))
+ (set-%symbol/make-local!! Qnil false-procedure)
+ (set-%symbol/make-all-local!! Qnil false-procedure)
+ (set-%symbol/kill-local!! Qnil false-procedure)
+ (set-%symbol/set-docstring!! Qnil false-procedure)
+ Qnil))
+
+(define Qt
+ (let ((Qt (%%intern "t" initial-obarray
+ (string-hash-mod "t" (vector-length initial-obarray)))))
+ ((%symbol/set-value! Qt) Qt)
+ (set-%symbol/unbound!!
+ Qt (lambda (val) val (error:%signal Qsetting-constant (list Qt))))
+ (set-%symbol/set-value!!
+ Qt (lambda (val) val (error:%signal Qsetting-constant (list Qt))))
+ (set-%symbol/set-default!!
+ Qt (lambda (val) val (error:%signal Qsetting-constant (list Qt))))
+ (set-%symbol/make-local!! Qt false-procedure)
+ (set-%symbol/make-all-local!! Qt false-procedure)
+ (set-%symbol/kill-local!! Qt false-procedure)
+ (set-%symbol/set-docstring!! Qt false-procedure)
+ Qt))
+
+(define Qsetting-constant
+ (%%intern "setting-constant" initial-obarray
+ (string-hash-mod "setting-constant"
+ (vector-length initial-obarray))))
+
+(define Qvariable-documentation
+ (%%intern "variable-documentation" initial-obarray
+ (string-hash-mod "variable-documentation"
+ (vector-length initial-obarray))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Primitives for word-abbrev mode.
+
+Only a few trivial primitives, and those used by GNUS, have been
+implemented. |#
+
+(declare (usual-integrations))
+\f
+#| An abbrev table is an obarray.
+ Each defined abbrev is represented by a symbol in that obarray
+ whose print name is the abbreviation.
+ The symbol's value is a string which is the expansion.
+ If its function definition is non-nil, it is called
+ after the expansion is done.
+ The plist slot of the abbrev symbol is its usage count. |#
+
+(DEFUN (el:make-abbrev-table)
+ "Create a new, empty abbrev table object."
+ (make-vector 59 0))
+
+(DEFUN (el:clear-abbrev-table table)
+ "Undefine all abbrevs in abbrev table TABLE, leaving it empty."
+ (%set-symbol-value! Qabbrevs-changed Qt)
+ (let ((table (CHECK-VECTOR table)))
+ (vector-fill! table 0))
+ '())
+\f
+(DEFUN (el:define-abbrev table name expansion #!optional hook count)
+ "Define an abbrev in TABLE named NAME, to expand to EXPANSION or call HOOK.
+NAME and EXPANSION are strings. HOOK is a function or nil.
+To undefine an abbrev, define it with EXPANSION = nil"
+ (let ((table (CHECK-VECTOR table))
+ (name (CHECK-STRING name))
+ (expansion (if (null? expansion)
+ false
+ (CHECK-STRING expansion)))
+ (count (if (either-default? count)
+ 0
+ (CHECK-NUMBER count))))
+ (let ((sym (%intern name table)))
+ (let ((oexp (%symbol-value sym))
+ (ohook (%symbol-function sym)))
+ (if (not (and (equal? oexp expansion)
+ (equal? ohook hook)))
+ (%set-symbol-value! Qabbrevs-changed Qt)))
+ (%set-symbol-value! sym expansion)
+ (%fset! sym hook)
+ (%set-symbol-plist! sym count))
+ name))
+
+(DEFUN (el:define-global-abbrev name expansion)
+ "Define ABBREV as a global abbreviation for EXPANSION."
+ (interactive "sDefine global abbrev: \nsExpansion for %s: ")
+ (let ((name (CHECK-STRING name)))
+ (el:define-abbrev (%symbol-value Qglobal-abbrev-table)
+ (string-downcase name)
+ expansion '() 0)
+ name))
+
+(DEFUN (el:define-mode-abbrev name expansion)
+ "Define ABBREV as a mode-specific abbreviation for EXPANSION."
+ (interactive "sDefine mode abbrev: \nsExpansion for %s: ")
+ (let ((table (%symbol-value Qlocal-abbrev-table))
+ (name (CHECK-STRING name)))
+ (if (null? table)
+ (error:%signal Qerror (list "Major mode has no abbrev table"))
+ (el:define-abbrev table (string-downcase name) expansion '() 0))
+ name))
+
+(DEFUN (el:abbrev-symbol abbrev #!optional table)
+ "Return the symbol representing abbrev named ABBREV.
+Value is nil if that abbrev is not defined.
+Optional second arg TABLE is abbrev table to look it up in.
+Default is try buffer's mode-specific abbrev table, then global table."
+ (let ((abbrev (CHECK-STRING abbrev)))
+ (let ((sym (if (not (either-default? table))
+ (%intern-soft abbrev (CHECK-VECTOR table))
+ (let ((sym (%intern-soft
+ abbrev (CHECK-VECTOR
+ (%symbol-value Qlocal-abbrev-table)))))
+ (if (and (%symbol? sym)
+ (%symbol-bound? sym))
+ sym
+ (%intern-soft
+ abbrev
+ (CHECK-VECTOR
+ (%symbol-value Qglobal-abbrev-table))))))))
+ (if (and (%symbol? sym)
+ (%symbol-bound? sym))
+ sym
+ '()))))
+
+(DEFUN (el:abbrev-expansion abbrev #!optional table)
+ "Return the string that ABBREV expands into in the current buffer.
+Optionally specify an abbrev table; then ABBREV is looked up in that table only."
+ (let ((sym (el:abbrev-symbol abbrev table)))
+ (if (null? sym)
+ '()
+ (%symbol-value sym))))
+\f
+#| Punting the hard stuff...
+
+(DEFUN (el:expand-abbrev)
+ "Expand the abbrev before point, if it is an abbrev.
+Effective when explicitly called even when abbrev-mode is not enabled.
+Returns t if expansion took place."
+ (interactive "")
+ )
+
+(DEFUN (el:unexpand-abbrev)
+ "Undo the expansion of the last abbrev that expanded."
+ (interactive "")
+ )
+
+(DEFUN (el:insert-abbrev-table-description name readable)
+ "Insert before point a description of abbrev table named NAME.
+NAME is a symbol whose value is an abbrev table.
+If 2nd arg READABLE is non-nil, a readable description is inserted.
+Otherwise description is an expression,
+a call to define-abbrev-table which would
+define NAME exactly as it is currently defined."
+ )|#
+\f
+(DEFUN (el:define-abbrev-table tabname defns)
+ "Define TABNAME (a symbol) as an abbrev table name.
+Define abbrevs in it according to DEFINITIONS, a list of elements
+of the form (ABBREVNAME EXPANSION HOOK USECOUNT)."
+ (let ((tabname (CHECK-SYMBOL tabname)))
+ (let ((table
+ (if (and (%symbol-bound? tabname)
+ (not (null? (%symbol-value tabname))))
+ (CHECK-VECTOR (%symbol-value tabname))
+ (let ((table (el:make-abbrev-table)))
+ (%set-symbol-value! tabname table)
+ (%set-symbol-value!
+ Qabbrev-table-name-list
+ (cons tabname
+ (%symbol-value Qabbrev-table-name-list)))
+ table))))
+ (let loop ((defns defns))
+ (if (not (null? defns))
+ (let ((defn (el:car defns)))
+ (el:define-abbrev table
+ (el:car defn)
+ (el:car (el:cdr defn))
+ (el:car (el:cdr (el:cdr defn)))
+ (el:car (el:cdr (el:cdr (el:cdr defn)))))
+ (loop (el:cdr defns)))))))
+ '())
+\f
+(DEFVAR Qabbrev-table-name-list
+ (list (%intern "fundamental-mode-abbrev-table" initial-obarray)
+ (%intern "global-abbrev-table" initial-obarray))
+ "List of symbols whose values are abbrev tables.")
+
+(DEFVAR Qglobal-abbrev-table
+ (el:make-abbrev-table)
+ "The abbrev table whose abbrevs affect all buffers.
+Each buffer may also have a local abbrev table.
+If it does, the local table overrides the global one
+for any particular abbrev defined in both.")
+
+(DEFVAR Qfundamental-mode-abbrev-table
+ (el:make-abbrev-table)
+ "The abbrev table of mode-specific abbrevs for Fundamental Mode.")
+
+(DEFVAR Qlast-abbrev
+ '()
+ "The abbrev-symbol of the last abbrev expanded.")
+
+(DEFVAR Qlast-abbrev-text
+ '()
+ "The exact text of the last abbrev expanded.
+nil if the abbrev has already been unexpanded.")
+
+(DEFVAR Qlast-abbrev-location
+ 0
+ "The location of the last abbrev expanded.")
+
+(DEFVAR Qabbrev-start-location
+ '()
+ "Buffer position for expand-abbrev to use as the start of the abbrev.
+nil means use the word before point as the abbrev.
+Set to nil each time expand-abbrev is called.")
+
+(DEFVAR Qabbrev-start-location-buffer
+ '()
+ "Buffer that abbrev-start-location has been set for.
+Trying to expand an abbrev in any other buffer clears abbrev-start-location.")
+
+(DEFVAR Qlocal-abbrev-table
+ (%symbol-value Qfundamental-mode-abbrev-table)
+ "Local (mode-specific) abbrev table of current buffer.")
+(%make-variable-buffer-local! Qlocal-abbrev-table)
+
+(DEFVAR Qabbrevs-changed
+ '()
+ "Set non-nil by defining or altering any word abbrevs.")
+
+(DEFVAR Qabbrev-all-caps
+ '()
+ "*Set non-nil means expand multi-word abbrevs all caps if abbrev was so.")
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Storage allocation and gc for GNU Emacs Lisp interpreter. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:cons car cdr)
+ "Create a new cons, give it CAR and CDR as components, and return it."
+ (cons car cdr))
+
+(DEFUN (el:list . args)
+ "Return a newly created list whose elements are the arguments (any number)."
+ (apply list args))
+
+(DEFUN (el:make-list length init)
+ "Return a newly created list of length LENGTH, with each element being INIT."
+ (let ((length (CHECK-NATNUM length)))
+ (make-list length init)))
+\f
+(DEFUN (el:make-vector length init)
+ "Return a newly created vector of length LENGTH, with each element being INIT."
+ (let ((length (CHECK-NATNUM length)))
+ (make-vector length init)))
+
+(DEFUN (el:vector . args)
+ "Return a newly created vector with our arguments (any number) as its elements."
+ (apply vector args))
+\f
+(DEFUN (el:make-symbol name)
+ "Return a newly allocated uninterned symbol whose name is NAME.
+Its value and function definition are void, and its property list is NIL."
+ (let ((name (CHECK-STRING name)))
+ (%make-symbol name)))
+\f
+(DEFUN (el:make-marker)
+ "Return a newly allocated marker which does not point at any place."
+ ;; Emacs markers are all right inserting (only move when characters
+ ;; are inserted _behind_ them -- insertions at or after them don't
+ ;; affect them).
+ (make-temporary-mark false false false))
+\f
+(DEFUN (el:make-string length init)
+ "Return a newly created string of length LENGTH, with each element being INIT.
+Both LENGTH and INIT must be numbers."
+ (let ((length (CHECK-NATNUM length))
+ (init (CHECK-CHAR init)))
+ (make-string length init)))
+\f
+(DEFUN (el:purecopy object)
+ "Make a copy of OBJECT in pure storage.
+Recursively copies contents of vectors and cons cells.
+Does not copy symbols.
+
+NOTE: In Edwin, this just does a deep copy of lists, strings, and vectors."
+ (letrec ((purecopy
+ (lambda (object)
+ (cond ((mark? object)
+ (error:%signal
+ Qerror
+ (list "Attempt to copy a marker to pure storage")))
+ ((pair? object)
+ (cons (purecopy (car object))
+ (purecopy (cdr object))))
+ ((string? object)
+ (string-copy object))
+ ((vector? object)
+ (vector-map object purecopy))
+ (else object)))))
+ (purecopy object)))
+
+(define (vector-map vector procedure)
+ (let ((length (vector-length vector)))
+ (make-initialized-vector
+ length
+ (lambda (index)
+ (procedure (vector-ref vector index))))))
+\f
+(DEFUN (el:garbage-collect)
+ "Reclaim storage for Lisp objects no longer needed.
+Returns info on amount of space in use:
+ ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
+ (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS)
+Garbage collection happens automatically if you cons more than
+gc-cons-threshold bytes of Lisp data since previous garbage collection.
+
+NOTE: In Edwin, returns the number of free words in the heap. This
+number is incompatible with the expected association list, so Emacs
+programs examining the return value will signal an error."
+ (interactive "")
+ (let ((omessage (current-message)))
+ (message "Garbage collecting...")
+ ;;(let ((tem (el:nthcdr 30 (%symbol-value Qcommand-history))))
+ ;; (if (not (null? tem))
+ ;; (set-cdr! tem '())))
+ ;; Edwin automatically limits undo records.
+ (let ((free (gc-flip)))
+ (if omessage
+ (message omessage)
+ (message "Garbage collecting...done"))
+ free)))
+
+(DEFVAR Qgc-cons-threshold
+ 0
+ "*Number of bytes of consing between garbage collections.
+
+NOTE: This variable is meaningless in Edwin.")
+
+(DEFVAR Qpure-bytes-used
+ 0
+ "Number of bytes of sharable Lisp data allocated so far.
+
+NOTE: This variable is meaningless in Edwin.")
+
+(DEFVAR Qpurify-flag
+ unassigned
+ "Non-nil means loading Lisp code in order to dump an executable.
+
+NOTE: This variable is meaningless in Edwin.")
+
+(DEFVAR Qundo-threshold
+ unassigned
+ "Keep no more undo information once it exceeds this size.
+This threshold is applied when garbage collection happens.
+The size is counted as the number of bytes occupied,
+which includes both saved text and other data.
+
+NOTE: This variable cannot be set in Edwin."
+ (lambda ()
+ (environment-lookup (->environment '(edwin undo)) 'maximum-undo-chars))
+ ;;(lambda (value)
+ ;; (if (not (= value (environment-lookup (->environment '(edwin undo))
+ ;; 'maximum-undo-chars)))
+ ;; (editor-error
+ ;; "Setting undo-threshold is not supported by Edwin.")))
+ ;; It's probably safe to ignore settings.
+ identity-procedure)
+
+(DEFVAR Qundo-high-threshold
+ unassigned
+ "Don't keep more than this much size of undo information.
+A command which pushes past this size is itself forgotten.
+This threshold is applied when garbage collection happens.
+The size is counted as the number of bytes occupied,
+which includes both saved text and other data.
+
+NOTE: This variable cannot be set in Edwin."
+ (lambda ()
+ (environment-lookup (->environment '(edwin undo)) 'maximum-undo-chars))
+ ;;(lambda (value)
+ ;; (if (not (= value (environment-lookup (->environment '(edwin undo))
+ ;; 'maximum-undo-chars)))
+ ;; (editor-error
+ ;; "Setting undo-high-threshold is not supported by Edwin.")))
+ ;; It's probably safe to ignore settings.
+ identity-procedure)
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Buffer manipulation primitives for GNU Emacs.
+
+This cooperates with keymap.scm to implement the bridge between Emacs
+and Edwin modes. It currently does this by getting/storing the values
+of major-mode and mode-name through special accessors/mutators. |#
+
+(declare (usual-integrations))
+\f
+(define Qfundamental (%intern "fundamental" initial-obarray))
+(define Qfundamental-mode (%intern "fundamental-mode" initial-obarray))
+(define Qno-minibuffer (%intern "no-minibuffer" initial-obarray))
+
+(define (nsberror spec)
+ (if (string? spec)
+ (error:%signal Qerror (list "No buffer named %s" spec))
+ (error:%signal Qerror (list "Invalid buffer argument"))))
+
+(DEFUN (el:buffer-list)
+ "Return a list of all buffers."
+ (list-copy (buffer-list)))
+
+(DEFUN (el:get-buffer name)
+ "Return the buffer named NAME (a string).
+It is found by looking up NAME in buffer-alist.
+If there is no buffer named NAME, nil is returned.
+NAME may also be a buffer; it is returned."
+ (if (buffer? name)
+ name
+ (or (find-buffer (CHECK-STRING name))
+ '())))
+
+(DEFUN (el:get-file-buffer filename)
+ "Return the buffer visiting file FILENAME (a string).
+If there is no such buffer, nil is returned."
+ (let ((namestring (el:expand-file-name filename '())))
+ (or (pathname->buffer (->pathname namestring))
+ '())))
+
+(DEFUN (el:get-buffer-create name)
+ (let ((buffer (if (buffer? name)
+ name
+ (find-or-create-buffer (CHECK-STRING name)))))
+ ;; Enable undo in this buffer unless name starts with a space.
+ (let ((name (buffer-name buffer)))
+ (if (or (string-null? name)
+ (not (char=? #\Space (string-ref name 0))))
+ (enable-group-undo! (buffer-group buffer))))
+ buffer))
+
+(DEFUN (el:generate-new-buffer name)
+ "Creates and returns a buffer named NAME if one does not already exist,
+else tries adding successive suffixes to NAME until a new buffer-name is
+formed, then creates and returns a new buffer with that new name."
+ (if (buffer? name)
+ name
+ (el:get-buffer-create (new-buffer-name (CHECK-STRING name)))))
+
+(DEFUN (el:buffer-name #!optional buffer)
+ "Return the name of BUFFER, as a string.
+No arg means return name of current buffer."
+ (let ((buffer (if (either-default? buffer)
+ (%current-buffer)
+ (CHECK-BUFFER buffer))))
+ (buffer-name buffer)))
+
+(DEFUN (el:buffer-file-name #!optional buffer)
+ "Return name of file BUFFER is visiting, or NIL if none.
+No argument means use current buffer as BUFFER."
+ (let* ((buffer (if (either-default? buffer)
+ (%current-buffer)
+ (CHECK-BUFFER buffer)))
+ (pathname (buffer-pathname buffer)))
+ (if pathname
+ (->namestring pathname)
+ '())))
+
+(DEFUN (el:buffer-local-variables #!optional buffer)
+ "Return alist of variables that are buffer-local in BUFFER.
+No argument means use current buffer as BUFFER.
+Each element of the value looks like (SYMBOL . VALUE).
+Note that storing new VALUEs in these elements
+does not change the local values."
+ (let ((buffer (if (either-default? buffer)
+ (%current-buffer)
+ (CHECK-BUFFER buffer)))
+ (obarray (%symbol-value Qobarray)))
+ (map (lambda (entry)
+ (cons (%intern (symbol->string (variable-name (car entry))) obarray)
+ (cdr entry)))
+ (buffer-local-bindings buffer))))
+
+(DEFUN (el:buffer-modified-p #!optional buffer)
+ "Return t if BUFFER is modified since file last read in or saved.
+No argument means use current buffer as BUFFER."
+ (let ((buffer (if (either-default? buffer)
+ (%current-buffer)
+ (CHECK-BUFFER buffer))))
+ (if (buffer-modified? buffer) Qt '())))
+
+(DEFUN (el:set-buffer-modified-p flag)
+ "Mark current buffer as modified or unmodified according to FLAG."
+ (if (null? flag)
+ (buffer-not-modified! (%current-buffer))
+ (buffer-modified! (%current-buffer)))
+ flag)
+
+(DEFUN (el:rename-buffer name)
+ "Change current buffer's name to NEWNAME (a string)."
+ (interactive "sRename buffer (to new name): ")
+ (let* ((name (CHECK-STRING name))
+ (buffer (find-buffer name)))
+ (if (null? buffer)
+ (rename-buffer (%current-buffer) name)
+ (error:%signal Qerror (list "Buffer name \"%s\" is in use" name)))))
+
+(DEFUN (el:other-buffer #!optional buffer)
+ "Return most recently selected buffer other than BUFFER.
+Buffers not visible in windows are preferred to visible buffers.
+If no other exists, the buffer *scheme* is returned.
+If BUFFER is omitted or nil, some interesting buffer is returned."
+ (let ((buffer (if (either-default? buffer)
+ (%current-buffer)
+ (CHECK-BUFFER buffer))))
+ (%other-buffer buffer)))
+
+(define (%other-buffer buffer)
+ (or (other-buffer buffer)
+ (find-buffer "*scheme*")
+ (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 (port)
+ (identify-world port)
+ (newline port)
+ (newline port)))
+ (cmdl-message/strings
+ "You are in an interaction window of the Edwin editor."
+ "Type C-h for help. C-h m will describe some commands."))))
+ '()))
+
+(DEFUN (el:buffer-flush-undo buffer)
+ "Make BUFFER stop keeping undo information."
+ (let ((buffer (CHECK-BUFFER buffer)))
+ (disable-group-undo! (buffer-group buffer)))
+ '())
+
+(DEFUN (el:buffer-enable-undo #!optional buffer)
+ "Start keeping undo information for buffer BUFFER (default is current buffer)."
+ (let* ((buffer (if (either-default? buffer)
+ (%current-buffer)
+ (CHECK-BUFFER buffer)))
+ (group (buffer-group buffer)))
+ (if (not (group-undo-data group))
+ (enable-group-undo! group)))
+ '())
+
+(DEFUN (el:kill-buffer bufname)
+ "One arg, a string or a buffer. Get rid of the specified buffer.\n\
+Any processes that have this buffer as the `process-buffer' are killed\n\
+with `delete-process'."
+ (interactive "bKill buffer: ")
+ (let ((buffer (cond ((null? bufname) (%current-buffer))
+ ((buffer? bufname) bufname)
+ (else (find-buffer (CHECK-STRING bufname))))))
+ (if buffer
+ (begin
+ (el:other-buffer buffer)
+ (save-buffer-changes buffer)
+ (kill-buffer buffer))
+ (nsberror bufname)))
+ '())
+
+(DEFUN (el:switch-to-buffer bufname #!optional norecord)
+ "Select buffer BUFFER in the current window.
+BUFFER may be a buffer or a buffer name.
+Optional second arg NORECORD non-nil means
+do not put this buffer at the front of the list of recently selected ones.
+
+WARNING: This is NOT the way to work on another buffer temporarily
+within a Lisp program! Use `set-buffer' instead. That avoids messing with
+the window-buffer correspondences."
+ (interactive "BSwitch to buffer: ")
+ (let ((buffer (if (null? bufname)
+ (el:other-buffer (%current-buffer))
+ (el:get-buffer-create bufname)))
+ (record? (either-default? norecord)))
+ (%set-current-buffer! buffer)
+ (select-buffer-in-window
+ buffer
+ (let ((window (current-window)))
+ (if (minibuffer? (window-buffer window))
+ (el:next-window window Qno-minibuffer)
+ window))
+ record?))
+ '())
+
+(DEFUN (el:pop-to-buffer bufname #!optional other)
+ "Select buffer BUFFER in some window, preferably a different one.
+If pop-up-windows is non-nil, windows can be split to do this.
+If second arg OTHER-WINDOW is non-nil, insist on finding another
+window even if BUFFER is already visible in the selected window."
+ (let ((buffer (if (null? bufname)
+ (el:other-buffer (%current-buffer))
+ (el:get-buffer-create bufname)))
+ (require-other? (not (either-default? other))))
+ (pop-up-buffer buffer true require-other?)
+ (%set-current-buffer! buffer))
+ '())
+
+(DEFUN (el:current-buffer)
+ "Return the current buffer as a Lisp buffer object."
+ (%current-buffer))
+
+(DEFUN (el:set-buffer bufname)
+ "Set the current buffer to the buffer or buffer name supplied as argument.
+That buffer will then be the default for editing operations and printing.
+This function's effect can't last past end of current command
+because returning to command level
+selects the chosen buffer of the current window,
+and this function has no effect on what buffer that is.
+See also `save-excursion' when you want to select a buffer temporarily.
+Use `switch-to-buffer' or `pop-to-buffer' for interactive buffer selection."
+ (let ((buffer (el:get-buffer bufname)))
+ (if (null? buffer)
+ (nsberror bufname))
+ (if (not (memq buffer (buffer-list)))
+ (error:%signal Qerror (list "Selecting deleted buffer")))
+ (%set-current-buffer! buffer)
+ buffer))
+
+(DEFUN (el:barf-if-buffer-read-only)
+ "Signal a buffer-read-only error if the current buffer is read-only."
+ (if (buffer-read-only? (%current-buffer))
+ (begin
+ (error:%signal Qbuffer-read-only (list (%current-buffer)))
+ (el:barf-if-buffer-read-only))))
+
+(DEFUN (el:bury-buffer #!optional bufname)
+ "Put BUFFER at the end of the list of all buffers.
+There it is the least likely candidate for other-buffer to return;
+thus, the least likely buffer for \\[switch-to-buffer] to select by default.
+BUFFER is also removed from the selected window if it was displayed there."
+ (interactive "")
+ (let ((buffer (cond ((buffer? bufname) bufname)
+ ((either-default? bufname) (%current-buffer))
+ (else (let loop ((buf (el:get-buffer bufname)))
+ (if (null? buf)
+ (loop (el:get-buffer (nsberror bufname)))
+ buf))))))
+ (if (eq? buffer (current-buffer))
+ (and (previous-buffer) (select-buffer (previous-buffer))))
+ (bury-buffer buffer))
+ '())
+
+(DEFUN (el:erase-buffer)
+ "Delete the entire contents of the current buffer."
+ (let ((buffer (%current-buffer)))
+ (buffer-widen! buffer)
+ (delete-string (buffer-start buffer) (buffer-end buffer))
+ (set-buffer-save-length! buffer))
+ '())
+
+(DEFUN (el:list-buffers #!optional files)
+ "Display a list of names of existing buffers.
+Inserts it in buffer *Buffer List* and displays that.
+Note that buffers with names starting with spaces are omitted.
+Non-null optional arg FILES-ONLY means mention only file buffers.
+
+The M column contains a * for buffers that are modified.
+The R column contains a % for buffers that are read-only."
+ (interactive "P")
+ (%with-output-to-temp-buffer
+ "*Buffer List*"
+ (lambda ()
+ (with-output-to-mark
+ (buffer-point (%symbol-value Qstandard-output))
+ (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)
+ (%use-local-comtab! '())
+ (%set-elisp-major-mode! mode Qfundamental-mode)
+ (%set-elisp-mode-name! mode "Fundamental"))))
+ '())
+
+(DEFVAR Qdefault-mode-line-format
+ unassigned
+ "Default mode-line-format for buffers that do not override it.
+This is the same as (default-value 'mode-line-format)."
+ (lambda ()
+ (convert-from-edwin-to-elisp-modeline
+ (variable-default-value (ref-variable-object mode-line-format))))
+ (lambda (value)
+ (set-variable-default-value!
+ (ref-variable-object mode-line-format)
+ (convert-from-elisp-to-edwin-modeline value))))
+
+#|(DEFVAR Qdefault-abbrev-mode
+ unassigned
+ "Default abbrev-mode for buffers that do not override it.
+This is the same as (default-value 'abbrev-mode)."
+ (default-getter (ref-variable-object abbrev-mode))
+ (default-setter (ref-variable-object abbrev-mode)))|#
+
+(DEFVAR Qdefault-ctl-arrow
+ unassigned
+ "Default ctl-arrow for buffers that do not override it.
+This is the same as (default-value 'ctl-arrow).
+
+NOTE: This variable is variable can only be t in Edwin."
+ (constant-getter Qt)
+ identity-procedure)
+
+(DEFVAR Qdefault-truncate-lines
+ unassigned
+ "Default truncate-lines for buffers that do not override it.
+This is the same as (default-value 'truncate-lines).
+
+NOTE: This variable can only be a boolean in Edwin."
+ (boolean-default-getter (ref-variable-object truncate-lines))
+ (boolean-default-setter (ref-variable-object truncate-lines)))
+
+(DEFVAR Qdefault-fill-column
+ unassigned
+ "Default fill-column for buffers that do not override it.
+This is the same as (default-value 'fill-column).
+
+NOTE: This variable can only be an exact nonnegative integer in Edwin."
+ (default-getter (ref-variable-object fill-column))
+ (default-setter (ref-variable-object fill-column)))
+
+(DEFVAR Qdefault-left-margin
+ unassigned
+ "Default left-margin for buffers that do not override it.
+This is the same as (default-value 'left-margin).
+
+NOTE: This variable can only be an exact nonnegative integer in Edwin."
+ (default-getter (ref-variable-object left-margin))
+ (default-setter (ref-variable-object left-margin)))
+
+(DEFVAR Qdefault-tab-width
+ unassigned
+ "Default tab-width for buffers that do not override it.
+This is the same as (default-value 'tab-width).
+
+NOTE: This variable can only be an exact nonnegative integer in Edwin."
+ (default-getter (ref-variable-object tab-width))
+ (default-setter (ref-variable-object tab-width)))
+
+(DEFVAR Qdefault-case-fold-search
+ unassigned
+ "Default case-fold-search for buffers that do not override it.
+This is the same as (default-value 'case-fold-search).
+
+NOTE: This variable can only be a boolean in Edwin."
+ (default-getter (ref-variable-object case-fold-search))
+ (default-setter (ref-variable-object case-fold-search)))
+
+(DEFVAR Qmode-line-format
+ unassigned
+ "Template for displaying mode line for current buffer.
+Each buffer has its own value of this variable.
+Value may be a string, a symbol or a list or cons cell.
+For a symbol, its value is used (but it is ignored if t or nil).
+ A string appearing directly as the value of a symbol is processed verbatim
+ in that the %-constructs below are not recognized.
+For a list whose car is a symbol, the symbol's value is taken,
+ and if that is non-nil, the cadr of the list is processed recursively.
+ Otherwise, the caddr of the list (if there is one) is processed.
+For a list whose car is a string or list, each element is processed
+ recursively and the results are effectively concatenated.
+For a list whose car is an integer, the cdr of the list is processed
+ and padded (if the number is positive) or truncated (if negative)
+ to the width specified by that number.
+A string is printed verbatim in the mode line except for %-constructs:
+ (%-constructs are allowed when the string is the entire mode-line-format
+ or when it is found in a cons-cell or a list)
+ %b -- print buffer name. %f -- print visited file name.
+ %* -- print *, % or hyphen. %m -- print value of mode-name (obsolete).
+ %s -- print process status. %M -- print value of global-mode-string. (obs)
+ %p -- print percent of buffer above top of window, or top, bot or all.
+ %n -- print Narrow if appropriate.
+ %[ -- print one [ for each recursive editing level. %] similar.
+ %% -- print %. %- -- print infinitely many dashes.
+Decimal digits after the % specify field width to which to pad.
+
+NOTE: The set-value method for mode-line-format sets the Edwin
+variable mode-line-format to a _copy_ of the new value. Thus, you
+can't modify the buffer's mode-line by side-effecting the new value.
+Also, the Emacs symbols in the new value are replaced with Edwin
+variables. Setting the Emacs symbols to new values will cause the
+Edwin variables to be updated, but the new values cannot contain Emacs
+symbols. Edwin variables won't be substituted for the symbols and
+Edwin will signal an error."
+ (lambda ()
+ (convert-from-edwin-to-elisp-modeline (ref-variable mode-line-format)))
+ (lambda (value)
+ (set-variable-local-value!
+ (%current-buffer)
+ (ref-variable-object mode-line-format)
+ (convert-from-elisp-to-edwin-modeline value))))
+
+(define (convert-from-edwin-to-elisp-modeline modeline)
+ (let convert ((modeline modeline))
+ (cond ((pair? modeline)
+ (cons (convert (car modeline))
+ (convert (cdr modeline))))
+ ((variable? modeline)
+ (let ((symbol
+ (%intern (variable-name-string modeline) initial-obarray)))
+ (%make-symbol-variable! symbol)
+ symbol))
+ ((eq? modeline #t) Qt)
+ (else modeline))))
+
+(define (convert-from-elisp-to-edwin-modeline modeline)
+ (let convert ((modeline modeline))
+ (cond ((pair? modeline)
+ (cons (convert (car modeline))
+ (convert (cdr modeline))))
+ ((null? modeline) false)
+ ((eq? modeline Qt) #t)
+ ((%symbol? modeline)
+ (%make-symbol-variable! modeline)
+ (string->symbol (%symbol-name modeline)))
+ (else modeline))))
+
+(DEFVAR Qdefault-major-mode
+ unassigned
+ "*Major mode for new buffers. Defaults to fundamental-mode.
+nil here means use current buffer's major mode.
+
+NOTE: This variable can only be 'fundamental-mode in Edwin."
+ (constant-getter Qfundamental-mode)
+ identity-procedure)
+
+#| Plausible getter?
+
+ (lambda ()
+ (%mode->major-mode (ref-variable editor-default-mode)))
+
+ (define (%mode->major-mode mode)
+ ;; Since the value of major-mode is just a symbol that isn't
+ ;; guaranteed to be fbound to a function that sets up a buffer
+ ;; according to the named mode, I'll just return a random symbol and
+ ;; worry about this later.
+ (%intern (string-append "edwin:"
+ (symbol->string (mode-name mode)))
+ initial-obarray))|#
+
+#| Plausible setter?
+
+ (lambda (value)
+ (set-variable! editor-default-mode
+ (%major-mode->mode
+ (if (null? value)
+ (wrong-type-argument Qnon-null-symbolp value)
+ (CHECK-SYMBOL value)))))
+
+ (define elisp-symbol->edwin-mode-map (make-1d-table))
+
+ (define (%major-mode->mode sym)
+ ;; In order to have setting default-major-mode have any kind of
+ ;; useful affect, I'll invent an Edwin major mode that tries to
+ ;; activate an Emacs Lisp mode.
+ (1d-table/lookup
+ elisp-symbol->edwin-mode-map
+ sym
+ identity-procedure ; if-found
+ (lambda ()
+ (let* ((edwin-name (string-append "elisp:" (%symbol-name sym)))
+ (mode (make-mode (string->symbol edwin-name)
+ true
+ edwin-name
+ (ref-mode-object fundamental)
+ (string-append
+ "An Edwin mode that activates an Emacs"
+ "Lisp mode.\nSee documentation of the"
+ "Emacs Lisp symbol " (%symbol-name sym) ".")
+ (lambda (buffer)
+ (%with-current-buffer
+ buffer
+ (lambda ()
+ (%funcall sym '())))))))
+ (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.
+
+NOTE: This variable can only be a symbol in Edwin."
+ (lambda ()
+ (let* ((buffer (%current-buffer))
+ (mode (buffer-major-mode buffer)))
+ (if (elisp-mode? mode)
+ (%elisp-major-mode 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)
+ 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))
+
+(DEFVAR Qabbrev-mode
+ unassigned
+ "Non-nil turns on automatic expansion of abbrevs when inserted.
+Automatically becomes local when set in any fashion.
+
+NOTE: This variable can only be nil in Edwin."
+ (constant-getter '())
+ identity-procedure)
+
+(DEFVAR Qcase-fold-search
+ unassigned
+ "*Non-nil if searches should ignore case.
+Automatically becomes local when set in any fashion.
+
+NOTE: This variable can only be a boolean in Edwin."
+ (boolean-getter (ref-variable-object case-fold-search))
+ (boolean-setter (ref-variable-object case-fold-search)))
+
+(DEFVAR Qmode-name
+ unassigned
+ "Pretty name of current buffer's major mode (a string).
+
+NOTE: This variable can only be a string in Edwin."
+ (lambda ()
+ (%elisp-mode-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)
+ 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.
+Automatically becomes local when set in any fashion.
+
+NOTE: This variable can only be an exact nonnegative integer in Edwin.")
+
+(DEFVAR Qleft-margin
+ unassigned ;(ref-variable left-margin)
+ "*Column for the default indent-line-function to indent to.
+Linefeed indents to this column in Fundamental mode.
+Automatically becomes local when set in any fashion.
+
+NOTE: This variable can only be an exact nonnegative integer in Edwin.")
+
+(DEFVAR Qtab-width
+ unassigned ;(ref-variable tab-width)
+ "*Distance between tab stops (for display of tab characters), in columns.
+Automatically becomes local when set in any fashion.
+
+NOTE: This variable can only be an exact nonnegative integer in Edwin.")
+
+(DEFVAR Qctl-arrow
+ unassigned
+ "*Non-nil means display control chars with uparrow.
+Nil means use backslash and octal digits.
+Automatically becomes local when set in any fashion.
+
+NOTE: This variable can only be t in Edwin."
+ (constant-getter Qt)
+ identity-procedure)
+
+(DEFVAR Qtruncate-lines
+ unassigned
+ "*Non-nil means do not display continuation lines;
+give each line of text one screen line.
+Automatically becomes local when set in any fashion.
+
+Note that this is overridden by the variable
+truncate-partial-width-windows if that variable is non-nil
+and this buffer is not full-screen width.
+
+NOTE: This variable can only be a boolean in Edwin."
+ (boolean-getter (ref-variable-object truncate-lines))
+ (boolean-setter (ref-variable-object truncate-lines)))
+
+(DEFVAR Qdefault-directory
+ unassigned
+ "Name of default directory of current buffer. Should end with slash.
+
+NOTE: This variable can only be a string in Edwin."
+ (lambda ()
+ (->namestring (buffer-default-directory (%current-buffer))))
+ (lambda (value)
+ (let ((value (CHECK-STRING value)))
+ (set-buffer-default-directory! (%current-buffer) (->pathname value)))))
+
+(DEFVAR Qauto-fill-hook
+ unassigned
+ "Function called (if non-nil) after self-inserting a space at column
+beyond fill-column
+
+NOTE: This variable can only be nil in Edwin."
+ (constant-getter '())
+ identity-procedure)
+
+(%make-symbol-generic!
+ Qbuffer-file-name
+ (lambda ()
+ (let ((pathname (buffer-pathname (%current-buffer))))
+ (if pathname
+ (->namestring pathname)
+ '())))
+ (lambda (value)
+ (let ((value (CHECK-STRING value)))
+ (set-buffer-pathname! (%current-buffer) (->pathname value)))))
+(%put!
+ Qbuffer-file-name Qvariable-documentation
+ "Name of file visited in current buffer, or nil if not visiting a file.
+
+NOTE: This variable can only be a string or nil in Edwin.")
+
+(DEFVAR Qbuffer-auto-save-file-name
+ unassigned
+ "Name of file for auto-saving current buffer,
+or nil if buffer should not be auto-saved.
+
+NOTE: This variable can only be a string or nil in Edwin."
+ (lambda ()
+ (let ((pathname (buffer-auto-save-pathname (%current-buffer))))
+ (if pathname
+ (->namestring pathname)
+ '())))
+ (lambda (value)
+ (if (null? value)
+ (set-buffer-auto-save-pathname! (%current-buffer) false)
+ (let ((value (CHECK-STRING value)))
+ (set-buffer-auto-save-pathname! (%current-buffer)
+ (->pathname value))))))
+
+(%make-symbol-generic!
+ Qbuffer-read-only
+ (lambda ()
+ (if (buffer-read-only? (%current-buffer))
+ Qt
+ '()))
+ (lambda (value)
+ (if (null? value)
+ (set-buffer-writable! (%current-buffer))
+ (set-buffer-read-only! (%current-buffer)))
+ unspecific))
+(%put! Qbuffer-read-only Qvariable-documentation
+ "Non-nil if this buffer is read-only.
+
+NOTE: This variable will only evaluate to a boolean in Edwin.")
+
+(DEFVAR Qbuffer-backed-up
+ unassigned
+ "Non-nil if this buffer's file has been backed up.
+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?)
+ Qt
+ '()))
+ (lambda (value)
+ (vector-set!
+ (%current-buffer)
+ buffer-index:backed-up?
+ (cond ((eq? value Qt) true)
+ ((null? value) false)
+ (else (error:wrong-type-datum value "a boolean"))))))
+
+(DEFVAR Qbuffer-saved-size
+ unassigned
+ "Length of current buffer when last read in, saved or auto-saved.
+0 initially."
+ (lambda ()
+ (vector-ref (%current-buffer) buffer-index:save-length))
+ (lambda (value)
+ (vector-set! (%current-buffer) buffer-index:save-length value)))
+
+(DEFVAR Qselective-display
+ unassigned
+ "t enables selective display:
+ after a ^M, all the rest of the line is invisible.
+ ^M's in the file are written into files as newlines.
+Integer n as value means display only lines
+ that start with less than n columns of space.
+Automatically becomes local when set in any fashion.
+
+NOTE: This variable can only be nil in Edwin."
+ (constant-getter '())
+ ;; Punt error message. GNUS uses this. For now, just ignore the setting.
+ ;;(constant-setter Qselective-display '() "nil")
+ identity-procedure)
+
+(DEFVAR Qselective-display-ellipses
+ unassigned
+ "t means display ... on previous line when a line is invisible.
+Automatically becomes local when set in any fashion.
+
+NOTE: This variable can only by nil in Edwin."
+ (constant-getter '())
+ ;; Punt error message. GNUS uses this. For now, just ignore the setting.
+ ;;(constant-setter Qselective-display-ellipses '() "nil")
+ identity-procedure)
+
+(DEFVAR Qoverwrite-mode
+ unassigned
+ "Non-nil if self-insertion should replace existing text.
+Automatically becomes local when set in any fashion.
+
+NOTE: This variable can only be nil in Edwin."
+ ;; Add an insert daemon that deletes the chars that should have been
+ ;; overwritten?
+ (constant-getter '())
+ (constant-setter Qoverwrite-mode '() "nil"))
+
+(DEFVAR Qbuffer-undo-list
+ unassigned
+ "List of undo entries in current buffer.
+
+NOTE: This variable is not supported by Edwin."
+ (unimplemented-getter Qbuffer-undo-list)
+ (lambda (value)
+ (cond ((eq? Qt value)
+ (disable-group-undo! (buffer-group (%current-buffer))))
+ ((null? value)
+ (let ((group (buffer-group (%current-buffer))))
+ (disable-group-undo! group)
+ (enable-group-undo! group)))
+ (else
+ (editor-error "Setting el:buffer-undo-list to anything other
+than t or nil is not supported by Edwin.")))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Execution of byte code produced by bytecomp.el. |#
+
+(declare (usual-integrations))
+\f
+;;;; Top-level
+
+(define *pc*)
+(define *byte-code*)
+(define *constants*)
+(define *stack*)
+(define *stack-pointer*)
+
+;; A constant that distinguishes true return values from unbind counts.
+(define-integrable +unbind+ "not a value -- a return count!")
+
+(DEFUN (el:byte-code bytestr vector maxdepth)
+ (fluid-let ((*pc* 0)
+ (*byte-code* (CHECK-STRING bytestr))
+ (*constants* (CHECK-VECTOR vector))
+ (*stack* (make-vector (CHECK-NUMBER maxdepth)))
+ (*stack-pointer* 0))
+ (let ((value (dispatch)))
+ (if (or (eq? value +unbind+)
+ (and (pair? value)
+ (eq? (car value) +unbind+)))
+ (error:wrong-type-datum value "a regular value; not an unbind count")
+ value)))
+;;; What? No debuggers handle the dynamic state properly!?
+;;; Don't forget DOunwind_protect too.
+#|(let ((old-pc *pc*)
+ (old-byte-code *byte-code*)
+ (old-constants *constants*)
+ (old-stack *stack*)
+ (old-stack-pointer *stack-pointer*))
+ (set! *pc* 0)
+ (set! *byte-code* (CHECK-STRING bytestr))
+ (set! *constants* (CHECK-VECTOR vector))
+ (set! *stack* (make-vector (CHECK-NUMBER maxdepth)))
+ (set! *stack-pointer* 0)
+ (let ((value (dispatch)))
+ (set! *pc* old-pc)
+ (set! *byte-code* old-byte-code)
+ (set! *constants* old-constants)
+ (set! *stack* old-stack)
+ (set! *stack-pointer* old-stack-pointer)
+ (if (or (eq? value +unbind+)
+ (and (pair? value)
+ (eq? (car value) +unbind+)))
+ (error:wrong-type-datum value "a regular value; not an unbind count")
+ value)))|#)
+\f
+;;;; Opcodes
+ ; bytecomp.el uses decimal!
+(define-integrable Bvarref 8) ; #o010
+(define-integrable Bvarset 16) ; #o020
+(define-integrable Bvarbind 24) ; #o030
+(define-integrable Bcall 32) ; #o040
+(define-integrable Bunbind 40) ; #o050
+
+(define-integrable Bnth 56) ; #o070
+(define-integrable Bsymbolp 57) ; #o071
+(define-integrable Bconsp 58) ; #o072
+(define-integrable Bstringp 59) ; #o073
+(define-integrable Blistp 60) ; #o074
+(define-integrable Beq 61) ; #o075
+(define-integrable Bmemq 62) ; #o076
+(define-integrable Bnot 63) ; #o077
+(define-integrable Bcar 64) ; #o0100
+(define-integrable Bcdr 65) ; #o0101
+(define-integrable Bcons 66) ; #o0102
+(define-integrable Blist1 67) ; #o0103
+(define-integrable Blist2 68) ; #o0104
+(define-integrable Blist3 69) ; #o0105
+(define-integrable Blist4 70) ; #o0106
+(define-integrable Blength 71) ; #o0107
+(define-integrable Baref 72) ; #o0110
+(define-integrable Baset 73) ; #o0111
+(define-integrable Bsymbol_value 74) ; #o0112
+(define-integrable Bsymbol_function 75) ; #o0113
+(define-integrable Bset 76) ; #o0114
+(define-integrable Bfset 77) ; #o0115
+(define-integrable Bget 78) ; #o0116
+(define-integrable Bsubstring 79) ; #o0117
+(define-integrable Bconcat2 80) ; #o0120
+(define-integrable Bconcat3 81) ; #o0121
+(define-integrable Bconcat4 82) ; #o0122
+(define-integrable Bsub1 83) ; #o0123
+(define-integrable Badd1 84) ; #o0124
+(define-integrable Beqlsign 85) ; #o0125
+(define-integrable Bgtr 86) ; #o0126
+(define-integrable Blss 87) ; #o0127
+(define-integrable Bleq 88) ; #o0130
+(define-integrable Bgeq 89) ; #o0131
+(define-integrable Bdiff 90) ; #o0132
+(define-integrable Bnegate 91) ; #o0133
+(define-integrable Bplus 92) ; #o0134
+(define-integrable Bmax 93) ; #o0135
+(define-integrable Bmin 94) ; #o0136
+
+(define-integrable Bpoint 96) ; #o0140
+(define-integrable Bmark 97) ; #o0141 no longer generated as of v18
+(define-integrable Bgoto_char 98) ; #o0142
+(define-integrable Binsert 99) ; #o0143
+(define-integrable Bpoint_max 100) ; #o0144
+(define-integrable Bpoint_min 101) ; #o0145
+(define-integrable Bchar_after 102) ; #o0146
+(define-integrable Bfollowing_char 103) ; #o0147
+(define-integrable Bpreceding_char 104) ; #o0150
+(define-integrable Bcurrent_column 105) ; #o0151
+(define-integrable Bindent_to 106) ; #o0152
+(define-integrable Bscan_buffer 107) ; #o0153 No longer generated as of v18
+(define-integrable Beolp 108) ; #o0154
+(define-integrable Beobp 109) ; #o0155
+(define-integrable Bbolp 110) ; #o0156
+(define-integrable Bbobp 111) ; #o0157
+(define-integrable Bcurrent_buffer 112) ; #o0160
+(define-integrable Bset_buffer 113) ; #o0161
+(define-integrable Bread_char 114) ; #o0162
+(define-integrable Bset_mark 115) ; #o0163 this loser is no longer
+ ; generated as of v18
+(define-integrable Binteractive_p 116) ; #o0164 Needed since interactive-p
+ ; takes unevalled args
+
+(define-integrable Bconstant2 129) ; #o0201
+(define-integrable Bgoto 130) ; #o0202
+(define-integrable Bgotoifnil 131) ; #o0203
+(define-integrable Bgotoifnonnil 132) ; #o0204
+(define-integrable Bgotoifnilelsepop 133) ; #o0205
+(define-integrable Bgotoifnonnilelsepop 134) ; #o0206
+(define-integrable Breturn 135) ; #o0207
+(define-integrable Bdiscard 136) ; #o0210
+(define-integrable Bdup 137) ; #o0211
+
+(define-integrable Bsave_excursion 138) ; #o0212
+(define-integrable Bsave_window_excursion 139) ; #o0213
+(define-integrable Bsave_restriction 140) ; #o0214
+(define-integrable Bcatch 141) ; #o0215
+
+(define-integrable Bunwind_protect 142) ; #o0216
+(define-integrable Bcondition_case 143) ; #o0217
+(define-integrable Btemp_output_buffer_setup 144) ; #o0220
+(define-integrable Btemp_output_buffer_show 145) ; #o0221
+
+(define-integrable Bconstant 192) ; #o0300
+(define-integrable CONSTANTLIM 64) ; #o0100
+\f
+;;;; Utilities
+
+(define-integrable (FETCH)
+ (let ((byte (vector-8b-ref *byte-code* *pc*)))
+ (set! *pc* (fix:1+ *pc*))
+ byte))
+
+(define-integrable (FETCH2)
+ (let* ((byte1 (vector-8b-ref *byte-code* *pc*))
+ (byte2 (vector-8b-ref *byte-code* (fix:1+ *pc*))))
+ (set! *pc* (fix:+ *pc* 2))
+ (+ (* byte2 #x100) byte1)))
+
+(define-integrable (TOP)
+ (vector-ref *stack* (fix:-1+ *stack-pointer*)))
+
+;; Can't define-integrable!
+;; The result doesn't ensure that *stack-pointer* in the vector-set!
+;; isn't evaluated before any pushes and pops caused by evaluation of
+;; `value'.
+(declare (integrate-operator PUSH))
+(define (PUSH value)
+ (vector-set! *stack* *stack-pointer* value)
+ (set! *stack-pointer* (fix:1+ *stack-pointer*))
+ unspecific)
+
+(define-integrable (POP)
+ (set! *stack-pointer* (fix:-1+ *stack-pointer*))
+ (vector-ref *stack* *stack-pointer*))
+
+(define-integrable (DISCARD-list n)
+ (let loop ((n n)
+ (elts '()))
+ (if (fix:zero? n)
+ elts
+ (begin
+ (set! *stack-pointer* (fix:-1+ *stack-pointer*))
+ (loop (fix:-1+ n)
+ (cons (vector-ref *stack* *stack-pointer*)
+ elts))))))
+
+(define-integrable (DISCARD n)
+ (set! *stack-pointer* (fix:- *stack-pointer* n))
+ unspecific)
+
+(define-integrable (INDEX op base)
+ (let ((index (fix:- op base)))
+ (cond ((fix:= index 6)
+ (FETCH))
+ ((fix:= index 7)
+ (FETCH2))
+ (else index))))
+
+(define-integrable (CONSTANT n)
+ (vector-ref *constants* n))
+
+(declare (integrate-operator UNBIND))
+(define (UNBIND value)
+ (if (and (pair? value)
+ (eq? (car value) +unbind+))
+ ;; Value is an unbind count.
+ (let ((count (cdr value)))
+ (if (fix:zero? count)
+ (dispatch) ; Done unwinding; continue.
+ (begin ; Unwind some more.
+ (set-cdr! value (fix:-1+ count))
+ value)))
+ ;; Value is not an unbind count!
+ (error:wrong-type-datum value "an unbind count")))
+
+;; Similar to UNBIND, so it's easy to see every handler does one or the other.
+(define-integrable (CONTINUE value)
+ value
+ (dispatch))
+\f
+;;;; Handlers
+
+(define (dispatch)
+#| Scheme already does bounds checking... punt maxdepth.
+ (if (fix:> *stack-pointer* maxdepth)
+ (error:%signal
+ Qerror
+ (list
+ "Stack overflow in byte code (byte compiler bug), pc = %d" *pc*)))
+ (if (fix:< *stack-pointer* 0)
+ (error:%signal
+ Qerror
+ (list
+ "Stack underflow in byte code (byte compiler bug), pc = %d" *pc*)))|#
+ (let ((op (FETCH)))
+ (if (fix:< op Bconstant)
+ ((vector-ref *handlers* op) op)
+ (let ((index (fix:- op Bconstant)))
+ (if (fix:< index CONSTANTLIM)
+ (begin
+ (PUSH (CONSTANT index))
+ (dispatch))
+ (error "unknown opcode " op
+ " at pc=" *pc*
+ " in " *byte-code*))))))
+
+(define (DOvarref op)
+ (CONTINUE
+ (PUSH (%symbol-value (CONSTANT (INDEX op Bvarref))))))
+
+(define (DOvarset op)
+ (CONTINUE
+ (%set-symbol-value! (CONSTANT (INDEX op Bvarset))
+ (POP))))
+
+(define (DOvarbind op)
+ (UNBIND
+ (%specbind
+ (list (CONSTANT (INDEX op Bvarbind)))
+ (list (POP))
+ (lambda () (dispatch)))))
+
+(define (DOcall op)
+ (CONTINUE
+ (PUSH (apply
+ el:funcall
+ (DISCARD-list (fix:1+ (INDEX op Bcall)))))))
+
+(define (DOunbind op)
+ ;; Everything that needs to be unbound calls dispatch
+ ;; recursively. Return the unbind count.
+ (let ((index (index op Bunbind)))
+ (cons +unbind+ (fix:-1+ index))))
+
+(define (DOgoto op)
+ op
+ (CONTINUE
+ (set! *pc* (FETCH2))))
+
+(define (DOgotoifnil op)
+ op
+ (CONTINUE
+ (let ((branch-address (FETCH2)))
+ (if (null? (POP))
+ (set! *pc* branch-address)))))
+
+(define (DOgotoifnonnil op)
+ op
+ (CONTINUE
+ (let ((branch-address (FETCH2)))
+ (if (not (null? (POP)))
+ (set! *pc* branch-address)))))
+
+(define (DOgotoifnilelsepop op)
+ op
+ (CONTINUE
+ (let ((branch-address (FETCH2)))
+ (if (null? (TOP))
+ (set! *pc* branch-address)
+ (DISCARD 1)))))
+
+(define (DOgotoifnonnilelsepop op)
+ op
+ (CONTINUE
+ (let ((branch-address (FETCH2)))
+ (if (not (null? (TOP)))
+ (set! *pc* branch-address)
+ (DISCARD 1)))))
+
+(define (DOreturn op)
+ op
+ (POP))
+
+(define (DOdiscard op)
+ op
+ (CONTINUE
+ (DISCARD 1)))
+
+(define (DOdup op)
+ op
+ (CONTINUE
+ (PUSH (TOP))))
+
+(define (DOconstant2 op)
+ op
+ (CONTINUE
+ (PUSH (constant (FETCH2)))))
+
+(define (DOsave_excursion op)
+ op
+ (UNBIND
+ (%save-excursion
+ (lambda () (dispatch)))))
+
+(define (DOsave_window_excursion op)
+ op
+ (CONTINUE
+ (%save-window-excursion
+ (lambda () (PUSH (apply el:progn (POP)))))))
+
+(define (DOsave_restriction op)
+ op
+ (UNBIND
+ (%save-restriction
+ (lambda () (dispatch)))))
+
+(define (DOcatch op)
+ op
+ (CONTINUE
+ (let ((body (POP)))
+ (PUSH (%catch (POP)
+ (lambda () (el:eval body)))))))
+
+(define (DOunwind_protect op)
+ op
+ (UNBIND
+ (let ((unwind-forms (POP)))
+ #|(let ((value (dispatch)))
+ (apply el:progn unwind-forms)
+ value)|#
+ (%unwind-protect
+ (lambda () (dispatch))
+ (lambda () (apply el:progn unwind-forms))))))
+
+(define (DOcondition_case op)
+ op
+ (CONTINUE
+ (let* ((handlers (POP))
+ (bodyform (POP))
+ (var (POP)))
+ (PUSH (apply el:condition-case
+ var bodyform handlers)))))
+
+(define (DOtemp_output_buffer_setup op)
+ op
+ (CONTINUE
+ (%with-output-to-temp-buffer
+ (el:get-buffer-create (POP))
+ (lambda ()
+ (let ((value (dispatch)))
+ (if (eq? value +unbind+)
+ unspecific
+ (error:wrong-type-datum value "a with-output-to-buffer-temp-buffer throw")))))))
+
+(define (DOtemp_output_buffer_show op)
+ op
+ ;; Return to dispatch call inside
+ ;; %with-output-to-temp-buffer.
+ +unbind+)
+
+(define (DOnth op)
+ op
+ (CONTINUE
+ (let* ((list (POP))
+ (index (CHECK-NUMBER (POP))))
+ (PUSH (el:nth index list)))))
+
+(define (DOsymbolp op)
+ op
+ (CONTINUE
+ (PUSH (if (%symbol? (POP)) Qt '()))))
+
+(define (DOconsp op)
+ op
+ (CONTINUE
+ (PUSH (if (pair? (POP)) Qt '()))))
+
+(define (DOstringp op)
+ op
+ (CONTINUE
+ (PUSH (if (string? (POP)) Qt '()))))
+
+(define (DOlistp op)
+ op
+ (CONTINUE
+ (PUSH (let ((obj (POP)))
+ (if (or (null? obj) (pair? obj)) Qt '())))))
+
+(define (DOeq op)
+ op
+ (CONTINUE
+ (PUSH (let ((obj1 (POP)) ; don't care about order!
+ (obj2 (POP)))
+ (if (eq? obj1 obj2) Qt '())))))
+
+(define (DOmemq op)
+ op
+ (CONTINUE
+ (PUSH (let ((list (POP)))
+ (el:memq (POP) list)))))
+
+(define (DOnot op)
+ op
+ (CONTINUE
+ (PUSH (if (null? (POP)) Qt '()))))
+
+(define (DOcar op)
+ op
+ (CONTINUE
+ (PUSH (el:car (POP)))))
+
+(define (DOcdr op)
+ op
+ (CONTINUE
+ (PUSH (el:cdr (POP)))))
+
+(define (DOcons op)
+ op
+ (CONTINUE
+ (let ((cdr (POP)))
+ (PUSH (cons (POP) cdr)))))
+
+(define (DOlist1 op)
+ op
+ (CONTINUE
+ (PUSH (list (POP)))))
+
+(define (DOlist2 op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (list (POP) second)))))
+
+(define (DOlist3 op)
+ op
+ (CONTINUE
+ (let* ((third (POP))
+ (second (POP)))
+ (PUSH (list (POP) second third)))))
+
+(define (DOlist4 op)
+ op
+ (CONTINUE
+ (let* ((fourth (POP))
+ (third (POP))
+ (second (POP)))
+ (PUSH (list (POP) second third fourth)))))
+
+(define (DOlength op)
+ op
+ (CONTINUE
+ (PUSH (el:length (POP)))))
+
+(define (DOaref op)
+ op
+ (CONTINUE
+ (let ((index (POP)))
+ (PUSH (el:aref (POP) index)))))
+
+(define (DOaset op)
+ op
+ (CONTINUE
+ (let* ((value (POP))
+ (index (POP)))
+ (PUSH (el:aset (POP) index value)))))
+
+(define (DOsymbol_value op)
+ op
+ (CONTINUE
+ (PUSH (%symbol-value (POP)))))
+
+(define (DOsymbol_function op)
+ op
+ (CONTINUE
+ (PUSH (%symbol-function (POP)))))
+
+(define (DOset op)
+ op
+ (CONTINUE
+ (let ((value (POP)))
+ (PUSH (el:set (POP) value)))))
+
+(define (DOfset op)
+ op
+ (CONTINUE
+ (let ((value (POP)))
+ (PUSH (el:fset (POP) value)))))
+
+(define (DOget op)
+ op
+ (CONTINUE
+ (let ((property (POP)))
+ (PUSH (el:get (POP) property)))))
+
+(define (DOsubstring op)
+ op
+ (CONTINUE
+ (let* ((end (POP))
+ (start (POP)))
+ (PUSH (el:substring (POP) start end)))))
+
+(define (DOconcat2 op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:concat (POP) second)))))
+
+(define (DOconcat3 op)
+ op
+ (CONTINUE
+ (let* ((third (POP))
+ (second (POP)))
+ (PUSH (el:concat (POP) second third)))))
+
+(define (DOconcat4 op)
+ op
+ (CONTINUE
+ (let* ((fourth (POP))
+ (third (POP))
+ (second (POP)))
+ (PUSH (el:concat (POP) second third fourth)))))
+
+(define (DOsub1 op)
+ op
+ (CONTINUE
+ (PUSH (el:1- (POP)))))
+
+(define (DOadd1 op)
+ op
+ (CONTINUE
+ (PUSH (el:1+ (POP)))))
+
+(define (DOeqlsign op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:= (POP) second)))))
+
+(define (DOgtr op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:> (POP) second)))))
+
+(define (DOlss op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:< (POP) second)))))
+
+(define (DOleq op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:<= (POP) second)))))
+
+(define (DOgeq op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:>= (POP) second)))))
+
+(define (DOdiff op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:- (POP) second)))))
+
+(define (DOnegate op)
+ op
+ (CONTINUE
+ (PUSH (el:- (POP)))))
+
+(define (DOplus op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:+ (POP) second)))))
+
+(define (DOmax op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:max (POP) second)))))
+
+(define (DOmin op)
+ op
+ (CONTINUE
+ (let ((second (POP)))
+ (PUSH (el:min (POP) second)))))
+
+(define (DOpoint op)
+ op
+ (CONTINUE
+ (PUSH (el:point))))
+
+(define (DOmark op)
+ op
+ (CONTINUE
+ (PUSH (el:marker-position (el:mark-marker)))))
+
+(define (DOgoto_char op)
+ op
+ (CONTINUE
+ (PUSH (el:goto-char (POP)))))
+
+(define (DOinsert op)
+ op
+ (CONTINUE
+ (PUSH (el:insert (POP)))))
+
+(define (DOpoint_max op)
+ op
+ (CONTINUE
+ (PUSH (el:point-max))))
+
+(define (DOpoint_min op)
+ op
+ (CONTINUE
+ (PUSH (el:point-min))))
+
+(define (DOchar_after op)
+ op
+ (CONTINUE
+ (PUSH (el:char-after (POP)))))
+
+(define (DOfollowing_char op)
+ op
+ (CONTINUE
+ (PUSH (el:following-char))))
+
+(define (DOpreceding_char op)
+ op
+ (CONTINUE
+ (PUSH (el:preceding-char))))
+
+(define (DOcurrent_column op)
+ op
+ (CONTINUE
+ (PUSH (el:current-column))))
+
+(define (DOindent_to op)
+ op
+ (CONTINUE
+ (PUSH (el:indent-to (POP)))))
+
+(define (DOscan_buffer op)
+ op
+ (CONTINUE
+ ;; Generate an error!
+ (%symbol-function (%make-symbol "scan-buffer"))))
+
+(define (DOeolp op)
+ op
+ (CONTINUE
+ (PUSH (el:eolp))))
+
+(define (DOeobp op)
+ op
+ (CONTINUE
+ (PUSH (el:eobp))))
+
+(define (DObolp op)
+ op
+ (CONTINUE
+ (PUSH (el:bolp))))
+
+(define (DObobp op)
+ op
+ (CONTINUE
+ (PUSH (el:bobp))))
+
+(define (DOcurrent_buffer op)
+ op
+ (CONTINUE
+ (PUSH (%current-buffer))))
+
+(define (DOset_buffer op)
+ op
+ (CONTINUE
+ (PUSH (el:set-buffer (POP)))))
+
+(define (DOread_char op)
+ op
+ (CONTINUE
+ (PUSH (el:read-char))))
+
+(define (DOset_mark op)
+ op
+ (CONTINUE
+ (PUSH (el:set-marker (el:mark-marker)
+ (POP) (%current-buffer)))))
+
+(define (DOinteractive_p op)
+ op
+ (CONTINUE
+ (PUSH (el:interactive-p))))
+
+(define *handlers*
+ (vector
+ 0 0 0 0 0 0 0 0
+ ;; 8
+ DOvarref DOvarref DOvarref DOvarref DOvarref DOvarref DOvarref DOvarref
+ ;; 16
+ DOvarset DOvarset DOvarset DOvarset DOvarset DOvarset DOvarset DOvarset
+ ;; 24
+ DOvarbind DOvarbind DOvarbind DOvarbind DOvarbind DOvarbind DOvarbind
+ DOvarbind
+ ;; 32
+ DOcall DOcall DOcall DOcall DOcall DOcall DOcall DOcall
+ ;; 40
+ DOunbind DOunbind DOunbind DOunbind DOunbind DOunbind DOunbind DOunbind
+ ;; 48
+ 0 0 0 0 0 0 0 0
+ DOnth ; 56 #o070
+ DOsymbolp ; 57 #o071
+ DOconsp ; 58 #o072
+ DOstringp ; 59 #o073
+ DOlistp ; 60 #o074
+ DOeq ; 61 #o075
+ DOmemq ; 62 #o076
+ DOnot ; 63 #o077
+ DOcar ; 64 #o0100
+ DOcdr ; 65 #o0101
+ DOcons ; 66 #o0102
+ DOlist1 ; 67 #o0103
+ DOlist2 ; 68 #o0104
+ DOlist3 ; 69 #o0105
+ DOlist4 ; 70 #o0106
+ DOlength ; 71 #o0107
+ DOaref ; 72 #o0110
+ DOaset ; 73 #o0111
+ DOsymbol_value ; 74 #o0112
+ DOsymbol_function ; 75 #o0113
+ DOset ; 76 #o0114
+ DOfset ; 77 #o0115
+ DOget ; 78 #o0116
+ DOsubstring ; 79 #o0117
+ DOconcat2 ; 80 #o0120
+ DOconcat3 ; 81 #o0121
+ DOconcat4 ; 82 #o0122
+ DOsub1 ; 83 #o0123
+ DOadd1 ; 84 #o0124
+ DOeqlsign ; 85 #o0125
+ DOgtr ; 86 #o0126
+ DOlss ; 87 #o0127
+ DOleq ; 88 #o0130
+ DOgeq ; 89 #o0131
+ DOdiff ; 90 #o0132
+ DOnegate ; 91 #o0133
+ DOplus ; 92 #o0134
+ DOmax ; 93 #o0135
+ DOmin ; 94 #o0136
+ 0
+ DOpoint ; 96 #o0140
+ DOmark ; 97 #o0141
+ DOgoto_char ; 98 #o0142
+ DOinsert ; 99 #o0143
+ DOpoint_max ; 100 #o0144
+ DOpoint_min ; 101 #o0145
+ DOchar_after ; 102 #o0146
+ DOfollowing_char ; 103 #o0147
+ DOpreceding_char ; 104 #o0150
+ DOcurrent_column ; 105 #o0151
+ DOindent_to ; 106 #o0152
+ DOscan_buffer ; 107 #o0153
+ DOeolp ; 108 #o0154
+ DOeobp ; 109 #o0155
+ DObolp ; 110 #o0156
+ DObobp ; 111 #o0157
+ DOcurrent_buffer ; 112 #o0160
+ DOset_buffer ; 113 #o0161
+ DOread_char ; 114 #o0162
+ DOset_mark ; 115 #o0163
+ DOinteractive_p ; 116 #o0164
+ 0 0 0 0 0 0 0 0 0 0 0 0
+ DOconstant2 ; 129 #o0201
+ DOgoto ; 130 #o0202
+ DOgotoifnil ; 131 #o0203
+ DOgotoifnonnil ; 132 #o0204
+ DOgotoifnilelsepop ; 133 #o0205
+ DOgotoifnonnilelsepop ; 134 #o0206
+ DOreturn ; 135 #o0207
+ DOdiscard ; 136 #o0210
+ DOdup ; 137 #o0211
+ ;;
+ DOsave_excursion ; 138 #o0212
+ DOsave_window_excursion ; 139 #o0213
+ DOsave_restriction ; 140 #o0214
+ DOcatch ; 141 #o0215
+ ;;
+ DOunwind_protect ; 142 #o0216
+ DOcondition_case ; 143 #o0217
+ DOtemp_output_buffer_setup ; 144 #o0220
+ DOtemp_output_buffer_show ; 145 #o0221
+ ))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Call a Lisp function interactively.
+
+The emacs subr called "call-interactively" actually has nothing to do
+with calling commands interactively, other than prompting for
+interactive arguments.
+The notion of the current buffer is not normalized to the buffer of
+the selected window, nor is the value of the variable `this-command'
+updated.
+
+The real procedure for invoking commands as though the Emacs Lisp
+command dispatch mechanism had invoked them is `%call-interactively'.
+This procedure should be called with the true current buffer (the
+value returned by the Edwin procedure `current-buffer') and the
+interactive arguments, which are collected by
+`%interactive-arguments'. The procedure will set the Emacs Lisp
+emulation's notion of the current buffer, set `this-command', and
+anything else required of command dispatch. There might even be
+something it can do to help implement `interactive-p'.
+
+The Emacs Lisp function `interactive-p' returns t if it is inside an Emacs
+Lisp function that was called by Emacs' command key dispatching
+mechanism, not by `call-interactively' or by a macro. The following
+example code illustrates this behavior.
+
+(defun foo (arg)
+ (interactive "P")
+ (let ((arg (and (not (null)) (prefix-numeric-value arg))))
+ (message "foo(%s)..." arg)
+ (sit-for 1)
+ (cond ((or (null arg) (zerop arg))
+ (message "foo(%s)... (interactive-p) => %s"
+ arg (interactive-p))
+ (sit-for 3))
+ ((< arg 0)
+ (message "foo(%s)... interactively calling foo(%s)"
+ arg (1+ arg))
+ (sit-for 1)
+ (setq prefix-arg (1+ arg))
+ (call-interactively 'foo))
+ (t
+ (foo (1- arg))))))
+
+Show value of interactive-p after initial call.
+M-x f o o \r
+foo(nil)... (interactive-p) => t
+
+Show value of interactive-p after a recursive call.
+C-u 1 M-x f o o \r
+foo(1)...
+foo(0)... (interactive-p) => nil
+
+Using call-interactively.
+C-u - 1 M-x f o o \r
+foo(-1)... interactively calling foo(0)
+foo(-1)... interactively calling foo(0)
+foo(-1)... interactively calling foo(0)
+?
+
+Ahem. Well anyway...
+
+`interactive-p' is implemented in GNU Emacs by looking at the
+interpreter stack.
+
+To implement this efficiently in Edwin Scheme would be difficult.
+Luckily, in the entire Emacs distribution, `interactive-p' is used in
+only 5 funcalls all of which will behave acceptably if
+`interactive-p' always returns 't. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:interactive "e . args)
+ "Specify a way of parsing arguments for interactive use of a function.
+For example, write
+ (defun fun (arg) \"Doc string\" (interactive \"p\") ...use arg...)
+to make arg be the prefix numeric argument when foo is called as a command.
+This is actually a declaration rather than a function;
+ it tells call-interactively how to read arguments
+ to pass to the function.
+When actually called, interactive just returns nil.
+
+The argument of interactive is usually a string containing a code letter
+ followed by a prompt. (Some code letters do not use I/O to get
+ the argument and do not need prompts.) To prompt for multiple arguments,
+ give a code letter, its prompt, a newline, and another code letter, etc.
+If the argument is not a string, it is evaluated to get a list of
+ arguments to pass to the function.
+Just (interactive) means pass no args when calling interactively.
+\nCode letters available are:
+a -- Function name: symbol with a function definition.
+b -- Name of existing buffer.
+B -- Name of buffer, possibly nonexistent.
+c -- Character.
+C -- Command name: symbol with interactive function definition.
+d -- Value of point as number. Does not do I/O.
+D -- Directory name.
+f -- Existing file name.
+F -- Possibly nonexistent file name.
+k -- Key sequence (string).
+m -- Value of mark as number. Does not do I/O.
+n -- Number read using minibuffer.
+N -- Prefix arg converted to number, or if none, do like code `n'.
+p -- Prefix arg converted to number. Does not do I/O.
+P -- Prefix arg in raw form. Does not do I/O.
+r -- Region: point and mark as 2 numeric args, smallest first. Does no I/O.
+s -- Any string.
+S -- Any symbol.
+v -- Variable name: symbol that is user-variable-p.
+x -- Lisp expression read but not evaluated.
+X -- Lisp expression read and evaluated.
+In addition, if the first character of the string is '*' then an error is
+ signaled if the buffer is read-only.
+ This happens before reading any arguments."
+ args
+ '())
+
+(DEFUN (el:call-interactively function #!optional record)
+ "Call FUNCTION, reading args according to its interactive calling specs.
+The function contains a specification of how to do the argument reading.
+In the case of user-defined functions, this is specified by placing a call
+to the function `interactive' at the top level of the function body.
+See `interactive'.
+
+Optional second arg RECORD-FLAG non-nil
+means unconditionally put this command in the command-history.
+Otherwise, this is done only if an arg is read using the minibuffer."
+ (el:apply function
+ (%interactive-arguments function (not (either-default? record)))))
+
+(define (%call-interactively buffer command record?)
+ (%apply-interactively buffer command
+ (%interactive-arguments command record?)))
+
+(define (%apply-interactively buffer function args)
+ ;; el:call-interactively is actually nothing like calling a command
+ ;; interactively!
+ ;; THIS is how to call a command interactively -- as though from
+ ;; command dispatch.
+ (%with-current-buffer
+ buffer
+ (lambda ()
+ (%set-symbol-value! Qthis-command function)
+ (el:apply function args))))
+
+;;; This is basically (edwin command-reader)interactive-arguments, hacked to
+;;; record Emacs Lisp command invocations in the command-history as
+;;; invocations of the el:eval command, and to deal with interactive
+;;; specifications that generate multiple arguments (namely, "r").
+(define (%interactive-arguments function record?)
+ (if (%symbol? function)
+ (let ((function* (%function* function)))
+ (if (and (pair? function*) (eq? (car function*) Qautoload))
+ (do-autoload function* function))))
+ (let ((specification (%function-interactive-specification function))
+ (record-command-arguments
+ (lambda (arguments)
+ (let ((history command-history))
+ (set-car! history (cons 'el:eval (cons function arguments)))
+ (set! command-history (cdr history))))))
+ (cond ((string? specification)
+ (with-values
+ (lambda ()
+ (let ((end (string-length specification)))
+ (let loop
+ ((index
+ (if (and (not (zero? end))
+ (char=? #\* (string-ref specification 0)))
+ (begin
+ (if (buffer-read-only? (%current-buffer))
+ (el:barf-if-buffer-read-only))
+ 1)
+ 0)))
+ (if (< index end)
+ (let ((newline
+ (substring-find-next-char specification
+ index
+ end
+ #\newline)))
+ (with-values
+ (lambda ()
+ (%interactive-argument
+ (string-ref specification index)
+ (substring specification
+ (+ index 1)
+ (or newline end))))
+ (lambda (first-arguments
+ first-expressions
+ from-tty?)
+ (with-values
+ (lambda ()
+ (if newline
+ (loop (+ newline 1))
+ (values '() '() false)))
+ (lambda (rest-arguments
+ rest-expressions
+ any-from-tty?)
+ (values (append! first-arguments
+ rest-arguments)
+ (append! first-expressions
+ rest-expressions)
+ (or from-tty? any-from-tty?)))))))
+ (values '() '() false)))))
+ (lambda (arguments expressions any-from-tty?)
+ (if (or record?
+ (and any-from-tty?
+ (not (prefix-key-list? (current-comtabs)
+ (current-command-key)))))
+ (record-command-arguments expressions))
+ arguments)))
+ ;; Should probably signal an error...
+ ((not specification)
+ (if record? (record-command-arguments '()))
+ '())
+ (else
+ (let ((old-keys-read keyboard-keys-read))
+ (let ((arguments (el:eval specification)))
+ (if (not (list? arguments))
+ (error:wrong-type-datum arguments
+ "a list of interactive arguments"))
+ (if (or record? (not (= keyboard-keys-read old-keys-read)))
+ (record-command-arguments (map quotify-sexp arguments)))
+ arguments))))))
+
+;;; This is basically (edwin command-reader)interactive-argument, hacked to
+;;; deal with minor differences between Edwin and Emacs' interactive
+;;; specifications.
+(define (%interactive-argument key prompt)
+ (let ((prompting
+ (lambda (value)
+ (values (list value) (list (quotify-sexp value)) true)))
+ (prefix
+ (lambda (prefix)
+ (values (list prefix) (list (quotify-sexp prefix)) false)))
+ (varies
+ (lambda (value expression)
+ (values (list value) (list expression) false))))
+ (case key
+ ((#\a)
+ (prompting
+ (let ((obarray (%symbol-value Qobarray)))
+ (%intern (el:completing-read prompt obarray Qfboundp Qt '())
+ obarray))))
+ ((#\b)
+ (prompting
+ (buffer-name (prompt-for-existing-buffer prompt (current-buffer)))))
+ ((#\B)
+ (prompting (buffer-name (prompt-for-buffer prompt (current-buffer)))))
+ ((#\c)
+ (prompting (char->ascii (prompt-for-char prompt))))
+ ((#\C)
+ (prompting (el:read-command prompt)))
+ ((#\d)
+ (varies (el:point) '(POINT)))
+ ((#\D)
+ (prompting (prompt-for-directory prompt false)))
+ ((#\f)
+ (prompting (prompt-for-existing-file prompt false)))
+ ((#\F)
+ (prompting (prompt-for-file prompt false)))
+ ((#\k)
+ (prompting (prompt-for-key prompt (buffer-comtabs (%current-buffer)))))
+ ((#\m)
+ ;; The Emacs Lisp symbol `mark' should be fbound in simple.el...
+ (varies (el:marker-position (el:mark-marker)) '(MARK)))
+ ((#\n)
+ (prompting (prompt-for-number prompt false)))
+ ((#\N)
+ (prefix (or (command-argument-value (command-argument))
+ (prompt-for-number prompt false))))
+ ((#\p)
+ (prefix (or (command-argument-value (command-argument)) 1)))
+ ((#\P)
+ (prefix (edwin->elisp-raw-prefix (command-argument))))
+ ((#\r)
+ (values (list (el:region-beginning)
+ (el:region-end))
+ '((REGION-BEGINNING)(REGION-END))
+ false))
+ ((#\s)
+ (prompting (or (prompt-for-string prompt false 'NULL-DEFAULT) "")))
+ ((#\v)
+ (prompting (el:read-variable prompt)))
+ ((#\x)
+ (prompting (el:read-minibuffer prompt '())))
+ ((#\X)
+ (prompting (el:eval-minibuffer prompt '())))
+ (else
+ (error:%signal Qerror (list "Invalid control letter \"%c\" (%03o) in interactive calling string"
+ (char->ascii key)))))))
+
+(define-command el:eval
+ "Apply an Emacs Lisp function to given arguments. This command is
+not intended to be called interactively. Emacs commands are recorded
+in the command-history as though this command had been called."
+ (lambda ()
+ (error "The el:eval command is not intended for interactive use.")
+ '(error "The el:eval command is not intended for interactive use."))
+ (lambda (expression)
+ (el:eval expression)))
+
+(DEFUN (el:prefix-numeric-value raw)
+ "Return numeric meaning of raw prefix argument ARG.
+A raw prefix argument is what you get from (interactive \"P\")."
+ (cond ((null? raw) 1)
+ ((symbol? raw) -1)
+ ((pair? raw) (car raw))
+ ((number? raw) raw)
+ (else 1)))
+
+(DEFVAR Qprefix-arg
+ unassigned
+ "The value of the prefix argument for the next editing command.
+It may be a number, or the symbol - for just a minus sign as arg,
+or a list whose car is a number for just one or more C-U's
+or nil if no argument has been specified.
+
+You cannot examine this variable to find the argument for this command
+since it has been set to nil by the time you can look.
+Instead, you should use the variable current-prefix-arg, although
+normally commands can get this prefix argument with (interactive \"P\")."
+ (lambda ()
+ (elisp->edwin-raw-prefix
+ (if (pair? *next-argument*)
+ (car *next-argument*)
+ false)))
+ (lambda (value)
+ (set! *next-argument* (list (edwin->elisp-raw-prefix value)))))
+
+(DEFVAR Qcurrent-prefix-arg
+ unassigned
+ "The value of the prefix argument for this editing command.
+It may be a number, or the symbol - for just a minus sign as arg,
+or a list whose car is a number for just one or more C-U's
+or nil if no argument has been specified.
+This is what (interactive \"P\") returns."
+ (lambda ()
+ (edwin->elisp-raw-prefix
+ (if (pair? *command-argument*)
+ (car *command-argument*)
+ false)))
+ (lambda (value)
+ (set! *command-argument* (list (elisp->edwin-raw-prefix value)))))
+
+(define (edwin->elisp-raw-prefix raw)
+ (cond ((not raw) '())
+ ((eq? raw '-) Q-)
+ (else raw)))
+
+(define (elisp->edwin-raw-prefix raw)
+ (cond ((null? raw) false)
+ ((eq? raw Q-) '-)
+ (else raw)))
+
+#|(DEFVAR Qcommand-history
+ unassigned
+ "List of recent commands that read arguments from terminal.
+Each command is represented as a form to evaluate.
+
+NOTE: In Edwin, each element is a pair of a command name and its arguments.
+The get/set-value methods of command-history will translate from/to
+the Edwin command-history-list. The command-history should not be
+side-effected without re-setting the symbol value afterwards."
+ (lambda ()
+ (->elisp-command-history-list (command-history-list)))
+ (lambda (value)
+ value
+ (->edwin-command-history-list value)))|#
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Synchronous subprocess invocation for GNU Emacs. |#
+
+(DEFUN (el:call-process program #!optional infile buffer display . args)
+ "Call PROGRAM in separate process.
+Program's input comes from file INFILE (nil means /dev/null).
+Insert output in BUFFER before point; t means current buffer;
+ nil for BUFFER means discard it; 0 means discard and don't wait.
+Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
+Remaining arguments are strings passed as command arguments to PROGRAM.
+Returns nil if BUFFER is 0; otherwise waits for PROGRAM to terminate
+and returns a numeric exit status or a signal description string.
+If you quit, the process is killed with SIGKILL."
+ (let ((program (CHECK-STRING program))
+ (infile (if (either-default? infile)
+ "/dev/null"
+ (CHECK-STRING
+ (el:expand-file-name
+ (CHECK-STRING infile)
+ (buffer-default-directory (%current-buffer))))))
+ (buff (if (either-default? buffer)
+ false
+ (cond ((eq? buffer Qt) (%current-buffer))
+ ((zero? buffer) false)
+ (else (CHECK-BUFFER (el:get-buffer buffer))))))
+ (wait? (and (not (default-object? buffer)) (zero? buffer)))
+ (redisplay? (not (either-default? display)))
+ (program-args (if (either-default? args)
+ '()
+ (CHECK-STRINGS args))))
+ (lambda ()
+ (call-with-input-file infile
+ (lambda (inport)
+ (if wait?
+ (begin
+ (run-synchronous-process ...)
+
+(with-values make-pipe
+ (lambda (parent-read child-write)
+ (let ((child-read
+ (bind-condition-handler
+ (list condition-type:system-call-error)
+ (lambda (condition)
+ (report-file-error "Opening process input file"
+ (list infile) condition))
+ (lambda ()
+ (file-open-input-channel infile)))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ (begin
+ (start-process ...)
+ '()))))))))
+
+(DEFUN (el:call-process-region start end program #!optional delete
+ buffer display . args)
+ "Send text from START to END to a process running PROGRAM.
+Delete the text if DELETE is non-nil.
+Insert output in BUFFER before point; t means current buffer;
+ nil for BUFFER means discard it; 0 means discard and don't wait.
+Sixth arg DISPLAY non-nil means redisplay buffer as output is inserted.
+Remaining arguments are strings passed as command arguments to PROGRAM.
+Returns nil if BUFFER is 0; otherwise waits for PROGRAM to terminate
+and returns a numeric exit status or a signal description string.
+If you quit, the process is killed with SIGKILL.")
+
+(DEFVAR Qshell-file-name
+ unassigned
+ "*File name to load inferior shells from.
+Initialized from the SHELL environment variable.")
+
+(DEFVAR Qexec-path
+ unassigned
+ "*List of directories to search programs to run in subprocesses.
+Each element is a string (directory name) or nil (try default directory).")
+
+(DEFVAR Qexec-directory
+ "Directory that holds programs that come with GNU Emacs,
+intended for Emacs to invoke.")
+
+;#ifndef MAINTAIN_ENVIRONMENT
+(DEFVAR Qprocess-environment
+ "List of strings to append to environment of subprocesses that are started.
+Each string should have the format ENVVARNAME=VALUE.")
+;#endif
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Simple built-in editing commands. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:forward-char #!optional n)
+ "Move point right ARG characters (left if ARG negative).
+On reaching end of buffer, stop and signal error."
+ (interactive "p")
+ (let* ((buffer (%current-buffer))
+ (group (buffer-group buffer))
+ (n (if (either-default? n) 1 (CHECK-NUMBER n)))
+ (point (+ (mark-index (buffer-point buffer)) n)))
+ (cond ((< point (group-start-index group))
+ (set-buffer-point! buffer (buffer-start buffer))
+ (error:%signal Qbeginning-of-buffer '()))
+ ((> point (group-end-index group))
+ (set-buffer-point! buffer (buffer-end buffer))
+ (error:%signal Qend-of-buffer '()))
+ (else
+ (set-buffer-point! buffer (make-mark group point)))))
+ '())
+
+(DEFUN (el:backward-char #!optional n)
+ "Move point left ARG characters (right if ARG negative).
+On attempt to pass beginning or end of buffer, stop and signal error."
+ (interactive "p")
+ (el:forward-char (- (if (either-default? n) 1 (CHECK-NUMBER n)))))
+
+(DEFUN (el:forward-line #!optional n)
+ "If point is on line i, move to the start of line i + ARG.
+If there isn't room, go as far as possible (no error).
+Returns the count of lines left to move.
+With positive ARG, a non-empty line traversed at end of buffer
+ counts as one line successfully moved (for the return value)."
+ (interactive "p")
+ (let* ((buffer (%current-buffer))
+ (n (if (either-default? n) 1 (CHECK-NUMBER n)))
+ (mark (buffer-point buffer))
+ ;; Modified copy of Edwin's line-start...
+ (group (mark-group mark))
+ (finish
+ (lambda (i n)
+ (set-buffer-point! buffer (make-mark group i))
+ n)))
+ (if (fix:> n 0)
+ (let ((limit (group-end-index group)))
+ (let loop ((i (mark-index mark)) (n n))
+ (let ((j (group-find-next-char group i limit #\newline)))
+ (cond ((not j) (finish limit n))
+ ((fix:= n 1) (finish (fix:+ j 1) 0))
+ (else (loop (fix:+ j 1) (fix:- n 1)))))))
+ (let ((limit (group-start-index group)))
+ (let loop ((i (mark-index mark)) (n n))
+ (let ((j (group-find-previous-char group limit i #\newline)))
+ (cond ((fix:= n 0) (finish (if j (fix:+ j 1) limit) 0))
+ ((not j) (finish limit n))
+ (else (loop j (fix:+ n 1))))))))))
+
+(DEFUN (el:beginning-of-line #!optional n)
+ "Move point to beginning of current line.
+With argument ARG not nil or 1, move forward ARG - 1 lines first.
+If scan reaches end of buffer, stop there without error."
+ (interactive "p")
+ (let ((buffer (%current-buffer))
+ (n (if (either-default? n) 1 (CHECK-NUMBER n))))
+ (set-buffer-point! buffer
+ (line-start (buffer-point buffer) (-1+ n) 'LIMIT)))
+ '())
+
+(DEFUN (el:end-of-line #!optional n)
+ "Move point to end of current line.
+With argument ARG not nil or 1, move forward ARG - 1 lines first.
+If scan reaches end of buffer, stop there without error."
+ (interactive "p")
+ (let ((buffer (%current-buffer))
+ (n (if (either-default? n) 1 (CHECK-NUMBER n))))
+ (set-buffer-point! buffer
+ (line-end (buffer-point buffer) (-1+ n) 'LIMIT)))
+ '())
+
+(DEFUN (el:delete-char n #!optional killflag)
+ "Delete the following ARG characters (previous, with negative arg).
+Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).
+Interactively, ARG is the prefix arg, and KILLFLAG is set if
+ARG was explicitly specified."
+ (interactive "p\nP")
+ (let* ((buffer (%current-buffer))
+ (group (buffer-group buffer))
+ (n (CHECK-NUMBER n))
+ (point (buffer-point buffer))
+ (start (mark-index point))
+ (end (+ start n)))
+ (cond ((< end (group-start-index group))
+ (error:%signal Qbeginning-of-buffer '()))
+ ((> end (group-end-index group))
+ (error:%signal Qend-of-buffer '()))
+ ((either-default? killflag)
+ (delete-string (make-mark group start) (make-mark group end)))
+ (else
+ (kill-string (make-mark group start) (make-mark group end)))))
+ '())
+
+(DEFUN (el:delete-backward-char n #!optional killflag)
+ "Delete the previous ARG characters (following, with negative ARG).\n\
+Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).\n\
+Interactively, ARG is the prefix arg, and KILLFLAG is set if\n\
+ARG was explicitly specified."
+ (interactive "p\nP")
+ (el:delete-char (- (CHECK-NUMBER n)) (not (either-default? killflag))))
+
+(DEFUN (el:self-insert-command arg)
+ "Insert this character. Prefix arg is repeat-count."
+ (interactive "p")
+ (let ((arg (CHECK-NUMBER arg)))
+ (let* ((buffer (%current-buffer))
+ (point (buffer-point buffer)))
+ (%fixup-window-point-movement
+ buffer point
+ (lambda () (insert-chars (last-command-key) arg point)))))
+ '())
+
+(DEFUN (el:newline #!optional arg)
+ "Insert a newline. With arg, insert that many newlines.
+In Auto Fill mode, can break the preceding line if no numeric arg.
+
+NOTE: Doesn't do anything special in Auto Fill mode in Edwin."
+ (interactive "p")
+ (let ((arg (if (either-default? arg)
+ 1
+ (CHECK-NUMBER arg))))
+ (let* ((buffer (%current-buffer))
+ (point (buffer-point buffer)))
+ (%fixup-window-point-movement
+ buffer point
+ (lambda () (insert-newlines arg point)))))
+ '())
+
+
+;; simple.el references this.
+(DEFVAR Qblink-paren-hook
+ '()
+ "Function called, if non-nil, whenever a char with closeparen syntax is self-inserted.
+
+NOTE: This variable is not supported in Edwin.")
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. |#
+
+(declare (usual-integrations))
+\f
+;(define Qt (%intern "t" initial-obarray))
+;(define Qquote (%intern "quote" initial-obarray))
+(define Qlambda (%intern "lambda" initial-obarray))
+(define Qsubr (%intern "subr" initial-obarray))
+(define Qerror-conditions (%intern "error-conditions" initial-obarray))
+(define Qerror-message (%intern "error-message" initial-obarray))
+(define Qtop-level (%intern "top-level" initial-obarray))
+
+(define Qerror (%intern "error" initial-obarray))
+(define Qquit (%intern "quit" initial-obarray))
+(define Qwrong-type-argument
+ (%intern "wrong-type-argument" initial-obarray))
+(define Qargs-out-of-range (%intern "args-out-of-range" initial-obarray))
+(define Qvoid-function (%intern "void-function" initial-obarray))
+(define Qvoid-variable (%intern "void-variable" initial-obarray))
+;(define Qsetting-constant (%intern "setting-constant" initial-obarray))
+(define Qinvalid-read-syntax
+ (%intern "invalid-read-syntax" initial-obarray))
+
+(define Qinvalid-function (%intern "invalid-function" initial-obarray))
+(define Qwrong-number-of-arguments
+ (%intern "wrong-number-of-arguments" initial-obarray))
+(define Qno-catch (%intern "no-catch" initial-obarray))
+(define Qend-of-file (%intern "end-of-file" initial-obarray))
+(define Qarith-error (%intern "arith-error" initial-obarray))
+(define Qbeginning-of-buffer
+ (%intern "beginning-of-buffer" initial-obarray))
+(define Qend-of-buffer (%intern "end-of-buffer" initial-obarray))
+(define Qbuffer-read-only (%intern "buffer-read-only" initial-obarray))
+
+;(define Qlistp (%intern "listp" initial-obarray))
+;(define Qconsp (%intern "consp" initial-obarray))
+;(define Qsymbolp (%intern "symbolp" initial-obarray))
+;(define Qintegerp (%intern "integerp" initial-obarray))
+;(define Qnatnump (%intern "natnump" initial-obarray))
+;(define Qstringp (%intern "stringp" initial-obarray))
+;(define Qarrayp (%intern "arrayp" initial-obarray))
+;(define Qsequencep (%intern "sequencep" initial-obarray))
+;(define Qbufferp (%intern "bufferp" initial-obarray))
+;(define Qvectorp (%intern "vectorp" initial-obarray))
+;(define Qchar-or-string-p (%intern "char-or-string-p" initial-obarray))
+;(define Qmarkerp (%intern "markerp" initial-obarray))
+#|(define Qinteger-or-marker-p
+ (%intern "integer-or-marker-p" initial-obarray))|#
+;(define Qboundp (%intern "boundp" initial-obarray))
+;(define Qfboundp (%intern "fboundp" initial-obarray))
+
+;(define Qcdr (%intern "cdr" initial-obarray))
+
+(%put! Qerror Qerror-conditions (list Qerror))
+(%put! Qerror Qerror-message "error")
+(%put! Qquit Qerror-message "Quit")
+(%put! Qquit Qerror-conditions (list Qquit))
+(define (define-error errsym message)
+ (%put! errsym Qerror-message message)
+ (%put! errsym Qerror-conditions (list errsym Qerror)))
+(define-error Qwrong-type-argument "Wrong type argument")
+(define-error Qargs-out-of-range "Args out of range")
+(define-error Qvoid-function "Symbol's function definition is void")
+(define-error Qvoid-variable "Symbol's value as variable is void")
+(define-error Qsetting-constant "Attempt to set a constant symbol")
+(define-error Qinvalid-read-syntax "Invalid read syntax")
+(define-error Qinvalid-function "Invalid function")
+(define-error Qwrong-number-of-arguments "Wrong number of arguments")
+(define-error Qno-catch "No catch for tag")
+(define-error Qend-of-file "End of file during parsing")
+(define-error Qarith-error "Arithmetic error")
+(define-error Qbeginning-of-buffer "Beginning of buffer")
+(define-error Qend-of-buffer "End of buffer")
+(define-error Qbuffer-read-only "Buffer is read-only")
+
+(define (wrong-type-argument predicate value)
+ (let ((new-value (error:%signal Qwrong-type-argument
+ (list predicate value))))
+ (if (null? (el:funcall predicate new-value))
+ (wrong-type-argument predicate new-value)
+ new-value)))
+
+;;; Data type predicates
+
+(DEFUN (el:eq obj1 obj2)
+ "T if the two args are the same Lisp object."
+ (if (eqv? obj1 obj2) Qt '()))
+
+(DEFUN (el:null obj)
+ "T if OBJECT is nil."
+ (if (null? obj) Qt '()))
+
+(DEFUN (el:consp obj)
+ "T if OBJECT is a cons cell."
+ (if (pair? obj) Qt '()))
+
+(DEFUN (el:atom obj)
+ "T if OBJECT is not a cons cell. This includes nil."
+ (if (pair? obj) '() Qt))
+
+(DEFUN (el:listp obj)
+ "T if OBJECT is a list. This includes nil."
+ (if (or (pair? obj) (null? obj)) Qt '()))
+
+(DEFUN (el:nlistp obj)
+ "T if OBJECT is not a list. Lists include nil."
+ (if (or (pair? obj) (null? obj)) '() Qt))
+
+(DEFUN (el:integerp obj)
+ "T if OBJECT is a number."
+ (if (integer? obj) Qt '()))
+
+(DEFUN (el:natnump obj)
+ "T if OBJECT is a nonnegative number."
+ (if (and (integer? obj) (>= obj 0)) Qt '()))
+
+(DEFUN (el:symbolp obj)
+ "T if OBJECT is a symbol."
+ (cond ((null? obj) Qt)
+ ((%symbol? obj) Qt)
+ (else '())))
+
+;; Not an Emacs Lisp subr, but useful anyway.
+(DEFUN (el:non-null-symbolp obj)
+ "T if OBJECT is a symbol, but not nil."
+ (if (%symbol? obj) Qt '()))
+
+(DEFUN (el:vectorp obj)
+ "T if OBJECT is a vector."
+ (if (vector? obj) Qt '()))
+
+(DEFUN (el:stringp obj)
+ "T if OBJECT is a string."
+ (if (string? obj) Qt '()))
+
+(DEFUN (el:arrayp obj)
+ "T if OBJECT is an array (string or vector)."
+ (if (or (vector? obj) (string? obj)) Qt '()))
+
+(DEFUN (el:sequencep obj)
+ "T if OBJECT is a sequence (list or array)."
+ (if (or (null? obj) (pair? obj) (vector? obj) (string? obj)) Qt '()))
+
+(DEFUN (el:bufferp obj)
+ "T if OBJECT is an editor buffer."
+ (if (buffer? obj) Qt '()))
+
+(DEFUN (el:markerp obj)
+ "T if OBJECT is a marker (editor pointer)."
+ (if (mark? obj) Qt '()))
+
+(DEFUN (el:integer-or-marker-p obj)
+ "T if OBJECT is an integer or a marker (editor pointer)."
+ (if (or (integer? obj) (mark? obj)) Qt '()))
+
+(DEFUN (el:subrp obj)
+ "T if OBJECT is a built-in function."
+ (if (%subr? obj) Qt '()))
+
+(DEFUN (el:char-or-string-p obj)
+ "T if OBJECT is a character (a number) or a string."
+ (if (or (integer? obj) (string? obj)) Qt '()))
+
+;;; Extract and set components of lists
+
+(DEFUN (el:car list)
+ "Return the car of CONSCELL. If arg is nil, return nil."
+ (cond ((pair? list) (car list))
+ ((null? list) '())
+ (else (el:car (wrong-type-argument Qlistp list)))))
+
+(DEFUN (el:car-safe object)
+ "Return the car of OBJECT if it is a cons cell, or else nil."
+ (if (pair? object) (car object) '()))
+
+(DEFUN (el:cdr list)
+ "Return the cdr of CONSCELL. If arg is nil, return nil."
+ (cond ((pair? list) (cdr list))
+ ((null? list) '())
+ (else (el:cdr (wrong-type-argument Qlistp list)))))
+
+(DEFUN (el:cdr-safe object)
+ "Return the cdr of OBJECT if it is a cons cell, or else nil."
+ (if (pair? object) (cdr object) '()))
+
+(DEFUN (el:setcar cell newcar)
+ "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR."
+ (if (not (pair? cell))
+ (el:setcar (wrong-type-argument Qconsp cell) newcar)
+ (set-car! cell newcar))
+ newcar)
+
+(DEFUN (el:setcdr cell newcdr)
+ "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR."
+ (if (not (pair? cell))
+ (el:setcdr (wrong-type-argument Qconsp cell) newcdr)
+ (set-cdr! cell newcdr))
+ newcdr)
+
+;;; Extract and set components of symbols
+
+(DEFUN (el:boundp sym)
+ "T if SYMBOL's value is not void."
+ (if (%symbol-bound? (CHECK-SYMBOL sym)) Qt '()))
+
+(DEFUN (el:fboundp sym)
+ "T if SYMBOL's function definition is not void."
+ (if (%symbol-fbound? (CHECK-SYMBOL sym)) Qt '()))
+
+(DEFUN (el:makunbound sym)
+ "Make SYMBOL's value be void."
+ (let ((sym (CHECK-SYMBOL sym)))
+ (%set-symbol-unbound! sym)
+ sym))
+
+(DEFUN (el:fmakunbound sym)
+ "Make SYMBOL's function definition be void."
+ (let ((sym (CHECK-SYMBOL sym)))
+ (%set-symbol-funbound! sym)
+ sym))
+
+(DEFUN (el:symbol-function sym)
+ "Return SYMBOL's function definition."
+ (%symbol-function (CHECK-SYMBOL sym)))
+
+(DEFUN (el:symbol-plist sym)
+ "Return SYMBOL's property list."
+ (%symbol-plist (CHECK-SYMBOL sym)))
+
+(DEFUN (el:symbol-name sym)
+ "Return SYMBOL's name, a string."
+ (string-copy (%symbol-name (CHECK-SYMBOL sym))))
+
+(DEFUN (el:fset sym newdef)
+ "Set SYMBOL's function definition to NEWVAL, and return NEWVAL."
+ (let ((sym (CHECK-SYMBOL sym)))
+ (%fset! sym newdef)
+ (%make-edwin-command sym newdef))
+ newdef)
+
+(define (%fset! sym fun)
+ (if (and (not (null? autoload-queue))
+ (%symbol-fbound? sym))
+ (set! autoload-queue (cons (cons sym (%symbol-function sym))
+ autoload-queue)))
+ (%set-symbol-function! sym fun)
+ unspecific)
+
+(DEFUN (el:setplist sym newplist)
+ "Set SYMBOL's property list to NEWVAL, and return NEWVAL."
+ (%set-symbol-plist! (CHECK-SYMBOL sym) newplist)
+ newplist)
+
+;;; Getting and setting values of symbols
+
+;;; Given the raw contents of a symbol value cell,
+;;; return the Lisp value of the symbol.
+
+(DEFUN (el:symbol-value sym)
+ "Return SYMBOL's value."
+ (%symbol-value (CHECK-SYMBOL sym)))
+
+(DEFUN (el:default-value sym)
+ "Return SYMBOL's default value.
+This is the value that is seen in buffers that do not have their own values
+for this variable."
+ (%symbol-default (CHECK-SYMBOL sym)))
+
+(DEFUN (el:set sym newval)
+ "Set SYMBOL's value to NEWVAL, and return NEWVAL."
+ (%set-symbol-value! (CHECK-SYMBOL sym) newval))
+
+(DEFUN (el:set-default sym value)
+ "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
+The default value is seen in buffers that do not have their own values
+for this variable."
+ (%set-symbol-default! (CHECK-SYMBOL sym) value))
+
+(DEFUN (el:setq-default "e sym value)
+ "Set SYMBOL's default value to VAL. VAL is evaluated; SYMBOL is not.
+The default value is seen in buffers that do not have their own values
+for this variable."
+ (%set-symbol-default! (CHECK-SYMBOL sym) (el:eval value)))
+
+(DEFUN (el:make-variable-buffer-local sym)
+ "Make VARIABLE have a separate value for each buffer.
+At any time, the value for the current buffer is in effect.
+There is also a default value which is seen in any buffer which has not yet
+set its own value.
+The function `default-value' gets the default value and `set-default' sets it.
+Using `set' or `setq' to set the variable causes it to have a separate value
+for the current buffer if it was previously using the default value."
+ (interactive "vMake Variable Buffer Local: ")
+ (let ((sym (CHECK-SYMBOL sym)))
+ (if (or (null? sym) (eq? sym Qt))
+ (el:make-variable-buffer-local
+ (error:%signal
+ Qerror
+ (list (el:format "Symbol %s may not be buffer-local" sym))))
+ (begin
+ (%make-variable-buffer-local! sym)
+ sym))))
+
+(DEFUN (el:make-local-variable sym)
+ "Make VARIABLE have a separate value in the current buffer.\n\
+Other buffers will continue to share a common default value.\n\
+See also `make-variable-buffer-local'."
+ (interactive "vMake Local Variable: ")
+ (let ((sym (CHECK-SYMBOL sym)))
+ (if (or (null? sym) (eq? sym Qt))
+ (el:make-local-variable
+ (error:%signal
+ Qerror
+ (list (el:format "Symbol %s may not be buffer-local" sym))))
+ (begin
+ (%make-local-variable! sym)
+ sym))))
+
+(DEFUN (el:kill-local-variable sym)
+ "Make VARIABLE no longer have a separate value in the current buffer.
+From now on the default value will apply in this buffer."
+ (interactive "vKill Local Variable: ")
+ (%kill-local-variable! (CHECK-SYMBOL sym)))
+
+;;; Extract and set vector and string elements
+
+(DEFUN (el:aref vector idx)
+ "Return the element of ARRAY at index INDEX.
+ARRAY may be a vector or a string. INDEX starts at 0."
+ (let ((i (CHECK-NUMBER idx)))
+ (cond ((vector? vector)
+ (if (or (< i 0) (<= (vector-length vector) i))
+ (el:aref vector
+ (error:%signal Qargs-out-of-range
+ (list vector i)))
+ (vector-ref vector i)))
+ ((string? vector)
+ (if (or (< i 0) (<= (string-length vector) i))
+ (el:aref vector
+ (error:%signal Qargs-out-of-range
+ (list vector i)))
+ (char->ascii (string-ref vector i))))
+ (else
+ (el:aref (wrong-type-argument Qarrayp vector) idx)))))
+
+(DEFUN (el:aset vector idx newelt)
+ "Store into the element of ARRAY at index INDEX the value NEWVAL.
+ARRAY may be a vector or a string. INDEX starts at 0."
+ (let ((i (CHECK-NUMBER idx)))
+ (cond ((vector? vector)
+ (if (or (< i 0) (<= (vector-length vector) i))
+ (el:aset vector
+ (error:%signal Qargs-out-of-range
+ (list vector i))
+ newelt)
+ (begin
+ (vector-set! vector i newelt)
+ newelt)))
+ ((string? vector)
+ (let ((char (ascii->char (modulo (CHECK-NUMBER newelt) 255))))
+ (if (or (< i 0) (<= (string-length vector) i))
+ (el:aset vector
+ (error:%signal Qargs-out-of-range
+ (list vector i))
+ newelt)
+ (begin
+ (string-set! vector i char)
+ newelt))))
+ ((comtab? vector)
+ (el:define-key vector (char->string (ascii->char idx)) newelt))
+ (else
+ (el:aset (wrong-type-argument Qarrayp vector) idx newelt)))))
+
+
+;;; Arithmetic functions
+
+(DEFUN (el:= num1 num2)
+ "T if two args, both numbers, are equal."
+ (if (= (CHECK-NUMBER-COERCE-MARKER num1)
+ (CHECK-NUMBER-COERCE-MARKER num2))
+ Qt '()))
+
+(DEFUN (el:< num1 num2)
+ "T if first arg is less than second arg. Both must be numbers."
+ (if (< (CHECK-NUMBER-COERCE-MARKER num1)
+ (CHECK-NUMBER-COERCE-MARKER num2))
+ Qt '()))
+
+(DEFUN (el:> num1 num2)
+ "T if first arg is greater than second arg. Both must be numbers."
+ (if (> (CHECK-NUMBER-COERCE-MARKER num1)
+ (CHECK-NUMBER-COERCE-MARKER num2))
+ Qt '()))
+
+(DEFUN (el:<= num1 num2)
+ "T if first arg is less than or equal to second arg. Both must be numbers."
+ (if (<= (CHECK-NUMBER-COERCE-MARKER num1)
+ (CHECK-NUMBER-COERCE-MARKER num2))
+ Qt '()))
+
+(DEFUN (el:>= num1 num2)
+ "T if first arg is greater than or equal to second arg. Both must be numbers."
+ (if (>= (CHECK-NUMBER-COERCE-MARKER num1)
+ (CHECK-NUMBER-COERCE-MARKER num2))
+ Qt '()))
+
+(DEFUN (el:/= num1 num2)
+ "T if first arg is not equal to second arg. Both must be numbers."
+ (if (= (CHECK-NUMBER-COERCE-MARKER num1)
+ (CHECK-NUMBER-COERCE-MARKER num2))
+ '() Qt))
+
+(DEFUN (el:zerop num)
+ "T if NUMBER is zero."
+ (if (zero? (CHECK-NUMBER num)) Qt '()))
+
+(DEFUN (el:int-to-string num)
+ "Convert INT to a string by printing it in decimal, with minus sign if negative."
+ (number->string (CHECK-NUMBER num)))
+
+(DEFUN (el:string-to-int str)
+ "Convert STRING to an integer by parsing it as a decimal number."
+ (or (string->number (CHECK-STRING str)) 0))
+
+(DEFUN (el:+ . args)
+ "Return sum of any number of numbers."
+ (let loop ((accum 0)
+ (args args))
+ (if (pair? args)
+ (loop (+ accum (CHECK-NUMBER-COERCE-MARKER (car args)))
+ (cdr args))
+ accum)))
+
+(DEFUN (el:- . args)
+ "Negate number or subtract numbers.
+With one arg, negates it. With more than one arg,
+subtracts all but the first from the first."
+ (if (pair? args)
+ (let ((first (CHECK-NUMBER-COERCE-MARKER (car args))))
+ (if (pair? (cdr args))
+ (let loop ((accum first)
+ (args (cdr args)))
+ (if (pair? args)
+ (loop (- accum (CHECK-NUMBER-COERCE-MARKER (car args)))
+ (cdr args))
+ accum))
+ (- first)))
+ 0))
+
+(DEFUN (el:* . args)
+ "Returns product of any number of numbers."
+ (let loop ((accum 1)
+ (args args))
+ (if (pair? args)
+ (loop (* accum (CHECK-NUMBER-COERCE-MARKER (car args)))
+ (cdr args))
+ accum)))
+
+(DEFUN (el:/ first . rest)
+ "Returns first argument divided by rest of arguments."
+ (let loop ((accum (CHECK-NUMBER-COERCE-MARKER first))
+ (rest rest))
+ (if (pair? rest)
+ (loop (quotient accum
+ (let ((div (CHECK-NUMBER-COERCE-MARKER (car rest))))
+ (if (zero? div)
+ (error:%signal Qarith-error (list div))
+ div)))
+ (cdr rest))
+ accum)))
+
+(DEFUN (el:% int1 int2)
+ "Returns remainder of first arg divided by second."
+ (let ((num1 (CHECK-NUMBER-COERCE-MARKER int1))
+ (num2 (CHECK-NUMBER-COERCE-MARKER int2)))
+ (if (zero? num2)
+ (el:% num1 (error:%signal Qarith-error (list num2)))
+ (remainder num1 num2))))
+
+(DEFUN (el:max maximum . rest)
+ "Return largest of all the arguments (which must be numbers.)"
+ (let loop ((maximum (CHECK-NUMBER-COERCE-MARKER maximum))
+ (rest rest))
+ (if (pair? rest)
+ (loop (max maximum (CHECK-NUMBER-COERCE-MARKER (car rest)))
+ (cdr rest))
+ maximum)))
+
+(DEFUN (el:min minimum . rest)
+ "Return smallest of all the arguments (which must be numbers.)"
+ (let loop ((minimum (CHECK-NUMBER-COERCE-MARKER minimum))
+ (rest rest))
+ (if (pair? rest)
+ (loop (min minimum (CHECK-NUMBER-COERCE-MARKER (car rest)))
+ (cdr rest))
+ minimum)))
+
+(DEFUN (el:logand . rest)
+ "Return bitwise and of all the arguments (numbers)."
+ (bit-string->signed-integer
+ (let loop ((accum #*111111111111111111111111)
+ (rest rest))
+ (if (pair? rest)
+ (loop (bit-string-and
+ accum
+ (signed-integer->bit-string
+ 24 (min (CHECK-NUMBER-COERCE-MARKER (car rest))
+ #x7fffff)))
+ (cdr rest))
+ accum))))
+
+(DEFUN (el:logior . rest)
+ "Return bitwise or of all the arguments (numbers)."
+ (bit-string->signed-integer
+ (let loop ((accum #*000000000000000000000000)
+ (rest rest))
+ (if (pair? rest)
+ (loop (bit-string-or
+ accum
+ (signed-integer->bit-string
+ 24 (min (CHECK-NUMBER-COERCE-MARKER (car rest))
+ #x7fffff)))
+ (cdr rest))
+ accum))))
+
+(DEFUN (el:logxor . rest)
+ "Return bitwise exclusive-or of all the arguments (numbers)."
+ (bit-string->signed-integer
+ (let loop ((accum #*000000000000000000000000)
+ (rest rest))
+ (if (pair? rest)
+ (loop (bit-string-xor
+ accum
+ (signed-integer->bit-string
+ 24 (min (CHECK-NUMBER-COERCE-MARKER (car rest))
+ #x7fffff)))
+ (cdr rest))
+ accum))))
+
+(DEFUN (el:ash num1 num2)
+ "Return VALUE with its bits shifted left by COUNT.
+If COUNT is negative, shifting is actually to the right.
+In this case, the sign bit is duplicated."
+ (bit-string->signed-integer
+ (let ((num1 (CHECK-NUMBER-COERCE-MARKER num1))
+ (num2 (CHECK-NUMBER-COERCE-MARKER num2)))
+ (let ((old-bitstring
+ (signed-integer->bit-string 24 (min num1 #x7fffff))))
+ (if (negative? num2)
+ (let ((new-bitstring
+ (if (negative? num1)
+ (bit-string-copy #*111111111111111111111111)
+ (bit-string-copy #*000000000000000000000000))))
+ (bit-substring-move-right!
+ old-bitstring (- num2) 24
+ new-bitstring 0)
+ new-bitstring)
+ (let ((new-bitstring
+ (bit-string-copy #*000000000000000000000000)))
+ (bit-substring-move-right!
+ old-bitstring 0 (- 24 num2)
+ new-bitstring num2)
+ new-bitstring))))))
+
+(DEFUN (el:lsh num1 num2)
+ "Return VALUE with its bits shifted left by COUNT.
+If COUNT is negative, shifting is actually to the right.
+In this case, zeros are shifted in on the left."
+ (bit-string->signed-integer
+ (let ((num1 (CHECK-NUMBER-COERCE-MARKER num1))
+ (num2 (CHECK-NUMBER-COERCE-MARKER num2)))
+ (let ((old-bitstring
+ (signed-integer->bit-string 24 (min num1 #x7fffff)))
+ (new-bitstring
+ (bit-string-copy #*000000000000000000000000)))
+ (if (negative? num2)
+ (bit-substring-move-right!
+ old-bitstring (- num2) 24
+ new-bitstring 0)
+ (bit-substring-move-right!
+ old-bitstring 0 (- 24 num2)
+ new-bitstring num2))
+ new-bitstring))))
+
+(DEFUN (el:1+ num)
+ "Return NUMBER plus one."
+ (1+ (CHECK-NUMBER-COERCE-MARKER num)))
+
+(DEFUN (el:1- num)
+ "Return NUMBER minus one."
+ (-1+ (CHECK-NUMBER-COERCE-MARKER num)))
+
+(DEFUN (el:lognot num)
+ "Return the bitwise complement of ARG."
+ (bit-string->signed-integer
+ (bit-string-not
+ (signed-integer->bit-string
+ 24 (min (CHECK-NUMBER-COERCE-MARKER num)
+ #x7fffff)))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Lisp functions for making directory listings. |#
+
+#|(DEFUN (el:directory-files dirname #!optional full match)
+ "Return a list of names of files in DIRECTORY.
+If FULL is non-NIL, absolute pathnames of the files are returned.
+If MATCH is non-NIL, only pathnames containing that regexp are returned.")|#
+\f
+#|(DEFUN (el:file-name-completion file dirname)
+ "Complete file name FILE in directory DIR.
+Returns the longest string common to all filenames in DIR
+that start with FILE.
+If there is only one and FILE matches it exactly, returns t.
+Returns nil if DIR contains no name starting with FILE."
+ (let ((file (CHECK-STRING file))
+ (dir (CHECK-STRING dirname)))
+ (if (string-null? file)
+ file
+ (filename-complete-string
+ (string-append
+ (->namestring (pathname-as-directory (el:expand-filename dirname)))
+ file)
+ (lambda (filename) filename Qt) ;if-unique
+ (lambda (dir thunk-of-some-sort...) ;if-not-unique
+ ...)
+ (lambda () '()) ;if-not-found
+ ))))|#
+
+(DEFUN (el:file-name-all-completions file dirname)
+ "Return a list of all completions of file name FILE in directory DIR."
+ ;;file_name_completion (file, dirname, 1, 0)
+ (let ((file (CHECK-STRING file))
+ (dirname (el:expand-file-name dirname)))
+ (filename-complete-string
+ (pathname-new-name (pathname-as-directory dirname) file)
+ (lambda (pathname) ;if-unique
+ (list (file-namestring pathname)))
+ (lambda (dir-pathname get-completions) ;if-not-unique
+ dir-pathname
+ (map file-namestring (get-completions)))
+ null-procedure ;if-not-found
+ )))
+
+#| (el:file-name-all-completions "sh" "/bin") ;if-unique
+ In Edwin: ("sh")
+ (el:file-name-all-completions "s" "/bin") ;if-not-unique
+ In Edwin: ("scm6003" "sed" "sh" "size" "sleep" "sort" "strip"...)
+ (el:file-name-all-completions "bogus" "/bin") ;if-not-found
+ In Edwin: ()
+ (el:file-name-all-completions "bogus" "/bogus")
+ In Edwin: () |#
+
+(DEFUN (el:file-attributes filename)
+ "Return a list of attributes of file FILENAME.
+Value is nil if specified file cannot be opened.
+Otherwise, list elements are:
+ 0. t for directory, string (name linked to) for symbolic link, or nil.
+ 1. Number of links to file.
+ 2. File uid.
+ 3. File gid.
+ 4. Last access time, as a list of two integers.
+ First integer has high-order 16 bits of time, second has low 16 bits.
+ 5. Last modification time, likewise.
+ 6. Last status change time, likewise.
+ 7. Size in bytes.
+ 8. File modes, as a string of ten letters or dashes as in ls -l.
+ 9. t iff file's gid would change if file were deleted and recreated.
+10. inode number.
+
+If file does not exists, returns nil."
+ (let ((fatts (file-attributes (el:expand-file-name filename))))
+ (define (split int)
+ (let ((qr (integer-divide int #x10000)))
+ (list (integer-divide-quotient qr) (integer-divide-remainder qr))))
+ (if fatts
+ (list
+ (let ((type (vector-ref fatts 0)))
+ (cond ((string? type) type)
+ ((eq? type #t) Qt)
+ ((eq? type #f) '())
+ (else (error:wrong-type-datum type "a file type"))))
+ (vector-ref fatts 1)
+ (vector-ref fatts 2)
+ (vector-ref fatts 3)
+ (split (vector-ref fatts 4))
+ (split (vector-ref fatts 5))
+ (split (vector-ref fatts 6))
+ (vector-ref fatts 7)
+ (vector-ref fatts 8)
+ Qt ; Just assume the worst.
+ (vector-ref fatts 9))
+ '())))
+\f
+(DEFVAR Qcompletion-ignored-extensions
+ unassigned ;(ref-variable completion-ignored-extensions)
+ "*Completion ignores filenames ending in any string in this list.")
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Lisp functions pertaining to editing. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:char-to-string n)
+ "Convert arg CHAR to a string containing that character."
+ (let ((n (CHECK-NUMBER n)))
+ (char->string (ascii->char (modulo n 255)))))
+
+(DEFUN (el:string-to-char str)
+ "Convert arg STRING to a character, the first character of that string."
+ (let ((str (CHECK-STRING str)))
+ (if (string-null? str)
+ 0
+ (char->ascii (string-ref str 0)))))
+
+(DEFUN (el:point)
+ "Return value of point, as an integer.
+Beginning of buffer is position (point-min)."
+ (%mark->number (buffer-point (%current-buffer))))
+
+(DEFUN (el:point-marker)
+ "Return value of point, as a marker object."
+ (mark-right-inserting-copy (buffer-point (%current-buffer))))
+
+(DEFUN (el:goto-char n)
+ "One arg, a number. Set point to that number.
+Beginning of buffer is position (point-min), end is (point-max)."
+ (interactive "NGoto char: ")
+ (let* ((buffer (%current-buffer))
+ (point (CHECK-MARKER-COERCE-INT n buffer)))
+ (set-buffer-point! buffer point)
+ (%mark->number point)))
+
+(DEFUN (el:region-beginning)
+ "Return position of beginning of region, as an integer."
+ (let ((buffer (%current-buffer)))
+ (let ((mark (%mark->number (buffer-mark buffer)))
+ (point (%mark->number (buffer-point buffer))))
+ (if (< mark point) mark point))))
+
+(DEFUN (el:region-end)
+ "Return position of end of region, as an integer."
+ (let ((buffer (%current-buffer)))
+ (let ((mark (%mark->number (buffer-mark buffer)))
+ (point (%mark->number (buffer-point buffer))))
+ (if (> mark point) mark point))))
+
+(DEFUN (el:mark-marker)
+ "Return this buffer's mark, as a marker object.
+Watch out! Moving this marker changes the mark position.
+The marker will not point anywhere if mark is not set."
+ (buffer-mark (%current-buffer)))
+
+(DEFUN (el:save-excursion "e . body)
+ "Save point (and mark), execute BODY, then restore point and mark.
+Executes BODY just like PROGN. Point and mark values are restored
+even in case of abnormal exit (throw or error)."
+ (%save-excursion (lambda () (apply el:progn body))))
+\f
+(DEFUN (el:buffer-size)
+ "Return the number of characters in the current buffer."
+ (group-length (buffer-group (%current-buffer))))
+
+(DEFUN (el:point-min)
+ "Return the minimum permissible value of point in the current buffer.
+This is 1, unless a clipping restriction is in effect."
+ (%mark->number (buffer-start (%current-buffer))))
+
+(DEFUN (el:point-min-marker)
+ "Return a marker to the beginning of the currently visible part of the buffer.
+This is the beginning, unless a clipping restriction is in effect."
+ (mark-right-inserting-copy (buffer-start (%current-buffer))))
+
+(DEFUN (el:point-max)
+ "Return the maximum permissible value of point in the current buffer.
+This is (1+ (buffer-size)), unless a clipping restriction is in effect,
+in which case it is less."
+ (%mark->number (buffer-end (%current-buffer))))
+
+(DEFUN (el:point-max-marker)
+ "Return a marker to the end of the currently visible part of the buffer.
+This is the actual end, unless a clipping restriction is in effect."
+ (mark-right-inserting-copy (buffer-end (%current-buffer))))
+
+(DEFUN (el:following-char)
+ "Return the character following point, as a number."
+ (let ((char (mark-right-char (buffer-point (%current-buffer)))))
+ (if char
+ (char->ascii char)
+ 0)))
+
+(DEFUN (el:preceding-char)
+ "Return the character preceding point, as a number."
+ (let ((char (mark-left-char (buffer-point (%current-buffer)))))
+ (if char
+ (char->ascii char)
+ 0)))
+
+(DEFUN (el:bobp)
+ "Return T if point is at the beginning of the buffer.
+If the buffer is narrowed, this means the beginning of the narrowed part."
+ (if (group-start? (buffer-point (%current-buffer)))
+ Qt '()))
+
+(DEFUN (el:eobp)
+ "Return T if point is at the end of the buffer.
+If the buffer is narrowed, this means the end of the narrowed part."
+ (if (group-end? (buffer-point (%current-buffer)))
+ Qt '()))
+
+(DEFUN (el:bolp)
+ "Return T if point is at the beginning of a line."
+ (if (line-start? (buffer-point (%current-buffer)))
+ Qt '()))
+
+(DEFUN (el:eolp)
+ "Return T if point is at the end of a line.
+`End of a line' includes point being at the end of the buffer."
+ (if (line-end? (buffer-point (%current-buffer)))
+ Qt '()))
+
+(DEFUN (el:char-after pos)
+ "One arg, POS, a number. Return the character in the current buffer
+at position POS.
+If POS is out of range, the value is NIL."
+ (let ((index (CHECK-POSITION-COERCE-MARKER pos))
+ (group (buffer-group (%current-buffer))))
+ (or (and (<= (group-start-index group) index)
+ (< index (group-end-index group))
+ (char->ascii (group-right-char group index)))
+ '())))
+\f
+(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))
+
+(DEFUN (el:user-real-login-name)
+ "Return the name of the user's real uid, as a string.
+Differs from user-login-name when running under su."
+ (unix/uid->string ((ucode-primitive real-uid))))
+
+(DEFUN (el:user-uid)
+ "Return the effective uid of Emacs, as an integer."
+ (unix/current-uid))
+
+(DEFUN (el:user-real-uid)
+ "Return the real uid of Emacs, as an integer."
+ ((ucode-primitive real-uid)))
+
+(DEFUN (el:user-full-name)
+ "Return the full name of the user logged in, 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))
+
+(DEFUN (el:system-name)
+ "Return the name of the machine you are running on, as a string."
+ ((ucode-primitive full-hostname)))
+
+(define file-timestamp-pathname false)
+
+(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)))
+\f
+(DEFUN (el:insert . args)
+ "Any number of args, strings or chars. Insert them after point, moving point
+forward."
+ (let* ((buffer (%current-buffer))
+ (point (buffer-point buffer)))
+ (%fixup-window-point-movement
+ buffer point (lambda () (%insert point args))))
+ '())
+
+(define (%fixup-window-point-movement buffer point thunk)
+ ;; Emacs window points are right-inserting markers. They don't
+ ;; advance in front of text inserted at their location.
+ ;; Edwin window points are left-inserting markers that do.
+ ;; This procedure restores any window points that shouldn't have
+ ;; moved.
+ (let* ((windows (list-transform-positive
+ (buffer-windows buffer)
+ (lambda (window)
+ (and (not (current-window? window))
+ (mark= point (window-point window))))))
+ (indices (map (lambda (window) (mark-index (window-point window)))
+ windows)))
+ (let ((value (thunk)))
+ (for-each (lambda (window index)
+ (set-mark-index! (window-point window) index))
+ windows indices)
+ value)))
+
+(define (%insert point args)
+ ;; Don't fixup window points here. el:insert-before-markers relies
+ ;; on default Edwin behavior.
+ (let loop ((args args)(count 0))
+ (if (pair? args)
+ (let retry ((arg (car args)))
+ (cond ((integer? arg)
+ (insert-char arg point)
+ (loop (cdr args) (1+ count)))
+ ((string? arg)
+ (let ((string arg))
+ (insert-string string point)
+ (loop (cdr args) (+ count (string-length string)))))
+ (else
+ (retry (wrong-type-argument Qchar-or-string-p arg)))))
+ count)))
+
+(DEFUN (el:insert-before-markers . args)
+ "Any number of args, strings or chars. Insert them after point,
+moving point forward. Also, any markers pointing at the insertion point
+get relocated to point after the newly inserted text."
+ (let* ((buffer (%current-buffer))
+ (insertion-point (mark-index (buffer-point buffer)))
+ (size (%insert insertion-point args))
+ (new-point (+ size insertion-point)))
+ (for-each (lambda (mark)
+ (if (and (not (mark-left-inserting? mark))
+ (= insertion-point (mark-index mark)))
+ (set-mark-index! mark new-point)))
+ (buffer-group buffer)))
+ '())
+\f
+(DEFUN (el:insert-char char count)
+ "Insert COUNT (second arg) copies of CHAR (first arg).
+Both arguments are required."
+ (let ((char (CHECK-CHAR char))
+ (count (CHECK-NUMBER count)))
+ (let* ((buffer (%current-buffer))
+ (point (buffer-point buffer)))
+ (%fixup-window-point-movement
+ buffer point (lambda () (insert-chars char count point)))))
+ '())
+\f
+(DEFUN (el:buffer-substring b e)
+ "Return the contents of part of the current buffer as a string.
+The two arguments specify the start and end, as character numbers."
+ (let ((region (CHECK-REGION b e (%current-buffer))))
+ (extract-string (region-start region) (region-end region))))
+
+(DEFUN (el:buffer-string)
+ "Return the contents of the current buffer as a string."
+ (let ((buffer (%current-buffer)))
+ (extract-string (buffer-start buffer) (buffer-end buffer))))
+
+(DEFUN (el:insert-buffer-substring buf #!optional b e)
+ "Insert before point a substring of the contents buffer BUFFER.
+BUFFER may be a buffer or a buffer name.
+Arguments START and END are character numbers specifying the substring.
+They default to the beginning and the end of BUFFER."
+ (let ((buf (CHECK-BUFFER (el:get-buffer buf))))
+ (let ((start (if (either-default? b)
+ (buffer-start buf)
+ (CHECK-MARKER-COERCE-INT b buf)))
+ (end (if (either-default? e)
+ (buffer-end buf)
+ (CHECK-MARKER-COERCE-INT e buf))))
+ (let* ((buffer (%current-buffer))
+ (point (buffer-point buffer)))
+ (%fixup-window-point-movement
+ buffer point (lambda () (insert-region start end point)))))))
+\f
+(DEFUN (el:subst-char-in-region start end fromchar tochar #!optional noundo)
+ "From START to END, replace FROMCHAR with TOCHAR each time it occurs.
+If optional arg NOUNDO is non-nil, don't record this change for undo
+and don't mark the buffer as really changed."
+ (let ((buffer (%current-buffer)))
+ (let ((region (CHECK-REGION start end buffer))
+ (fromchar (CHECK-CHAR fromchar))
+ (tochar (CHECK-CHAR tochar))
+ (noundo? (not (either-default? noundo))))
+ (let ((doit
+ (lambda ()
+ (with-group-undo-disabled (buffer-group buffer)
+ (lambda ()
+ (region-transform!
+ region
+ (lambda (string)
+ (string-replace! string fromchar tochar)
+ string)))))))
+ (if noundo?
+ (let ((modified? (buffer-modified? buffer))
+ (truename (buffer-truename buffer)))
+ ;; suppress supersession check
+ (set-buffer-truename! buffer false)
+ (doit)
+ (set-buffer-truename! buffer truename)
+ (if (not modified?) (buffer-not-modified! buffer)))
+ (doit)))))
+ '())
+
+(DEFUN (el:delete-region start end)
+ "Delete the text between point and mark.
+When called from a program, expects two arguments,
+character numbers specifying the stretch to be deleted."
+ (interactive "r")
+ (let ((region (CHECK-REGION start end (%current-buffer))))
+ (delete-string (region-start region) (region-end region)))
+ '())
+
+(DEFUN (el:widen)
+ "Remove restrictions from current buffer, allowing full text to be seen and
+edited."
+ (interactive "")
+ (buffer-widen! (%current-buffer))
+ '())
+
+(DEFUN (el:narrow-to-region start end)
+ "Restrict editing in this buffer to the current region.
+The rest of the text becomes temporarily invisible and untouchable
+but is not deleted; if you save the buffer in a file, the invisible
+text is included in the file. \\[widen] makes all visible again.
+
+When calling from a program, pass two arguments; character numbers
+bounding the text that should remain visible."
+ (interactive "r")
+ (let ((region (CHECK-REGION start end (%current-buffer))))
+ (region-clip! region))
+ '())
+
+(DEFUN (el:save-restriction "e . body)
+ "Execute the body, undoing at the end any changes to current buffer's
+restrictions. Changes to restrictions are made by narrow-to-region or by
+widen. Thus, the restrictions are the same after this function as they were
+before it. The value returned is that returned by the last form in the body.
+
+This function can be confused if, within the body, you widen
+and then make changes outside the area within the saved restrictions.
+
+Note: if you are using both save-excursion and save-restriction,
+use save-excursion outermost."
+ (%save-restriction (lambda () (apply el:progn body))))
+
+(define (%save-restriction thunk)
+ (with-region-clipped!
+ (group-region (buffer-group (%current-buffer)))
+ thunk))
+\f
+(DEFUN (el:message string . args)
+ "Print a one-line message at the bottom of the screen.
+The first argument is a control string.
+It may contain %s or %d or %c to print successive following arguments.
+%s means print an argument as a string, %d means print as number in decimal,
+%c means print a number as a single character.
+The argument used by %s must be a string or a symbol;
+the argument used by %d or %c must be a number."
+ (let ((string (apply el:format string args)))
+ (message string)
+ string))
+
+(DEFUN (el:format string . args)
+ "Format a string out of a control-string and arguments.
+The first argument is a control string.
+It, and subsequent arguments substituted into it, become the value, which is a
+string.
+It may contain %s or %d or %c to substitute successive following arguments.
+%s means print an argument as a string, %d means print as number in decimal,
+%c means print a number as a single character.
+The argument used by %s must be a string or a symbol;
+the argument used by %d, %o, %x or %c must be a number."
+
+ (define (parse-format-directive string start end receiver)
+ ;; Tail-calls `receiver' with:
+ ;; - index of format escape character (i.e. #\%), or `false' if none;
+ ;; - index of format control character (possibly `end'), or `false';
+ ;; - the flags, width, and precision modifiers specified by the characters
+ ;; between the escape and control characters as described below), or
+ ;; `false'.
+ ;;
+ ;; Characters denoting modifiers of a format directive look like:
+ ;; `<flags><width><precision>'.
+ ;;
+ ;; <flags> may be any of the following characters. If any of them appears,
+ ;; the listed symbol is added to the `flags' list.
+ ;; #\l -- LONG-ARGUMENT
+ ;; #\- -- LEFT-JUSTIFY
+ ;; #\+ -- REQUIRE-SIGN
+ ;; #\space -- BLANK-SIGN
+ ;; #\# -- INDICATE-RADIX (i.e. 0123, 0x123, 123., ...)
+ ;; #\0 -- ZERO-PADDING
+ ;; <width> may match any of the following regexps. If it does, the
+ ;; width modifier takes on the specified value.
+ ;; `' -- false
+ ;; `[1-9][0-9]*' -- the matching digits are parsed as an integer
+ ;; `\*' -- the symbol named "*"
+ ;; <precision> may match any of the following regexps. If it does, the
+ ;; precision modifier takes on the specified value.
+ ;; `' -- false
+ ;; `\.[1-9][0-9]*' -- the matching digits are parsed as an integer
+ ;; `\.\*' -- the symbol named "*"
+ ;; `\.' -- ignored.
+
+ (define (parse-flags string start end receiver)
+ (let loop ((start start)
+ (flags '()))
+ (if (< start end)
+ (case (string-ref string start)
+ ((#\l) (loop (1+ start) (cons 'LONG-ARGUMENT flags)))
+ ((#\-) (loop (1+ start) (cons 'LEFT-JUSTIFY flags)))
+ ((#\+) (loop (1+ start) (cons 'REQUIRE-SIGN flags)))
+ ((#\space) (loop (1+ start) (cons 'BLANK-SIGN flags)))
+ ((#\#) (loop (1+ start) (cons 'INDICATE-RADIX flags)))
+ ((#\0) (loop (1+ start) (cons 'ZERO-PADDING flags)))
+ (else (receiver start (reverse! flags))))
+ (receiver start (reverse! flags)))))
+
+ (define char-set:not-numeric (char-set-invert char-set:numeric))
+
+ (define (parse-integer string start end receiver)
+ (if (and (< start end)
+ (char=? #\* (string-ref string start)))
+ (receiver (1+ start) '*)
+ (let ((end (or (substring-find-next-char-in-set
+ string start end char-set:not-numeric)
+ end)))
+ (receiver end (string->number (substring string start end))))))
+
+ (define parse-width-modifier parse-integer)
+
+ (define (parse-precision-modifier string start end receiver)
+ (if (and (< start end)
+ (char=? #\. (string-ref string start)))
+ (parse-integer string (1+ start) end receiver)
+ (receiver start false)))
+
+ (let ((escape (substring-find-next-char string start end #\%)))
+ (if escape
+ (parse-flags
+ string (1+ escape) end
+ (lambda (width-start flags)
+ (parse-width-modifier
+ string width-start end
+ (lambda (precision-start width)
+ (parse-precision-modifier
+ string precision-start end
+ (lambda (control precision)
+ (receiver escape control flags width precision)))))))
+ (receiver false false false false false))))
+
+ (let ((end (string-length string)))
+ (let loop ((start 0)
+ (output '())
+ (args args))
+ (parse-format-directive
+ string start end
+ (lambda (escape control flags width precision)
+ (if escape
+ (let ((prefix (substring string start escape))
+ (control-character (and (< control end)
+ (string-ref string control))))
+ (if control-character
+ (let ((entry (assq control-character format-methods)))
+ (if entry
+ ((cdr entry)
+ flags width precision args
+ (lambda (new-output remaining-args)
+ (loop (1+ control)
+ `(,new-output ,prefix . ,output)
+ remaining-args)))
+ (error:%signal
+ Qerror (list "Invalid format operation %%%c"
+ control-character))))
+ (error:%signal
+ Qerror (list "Incomplete format directive %s"
+ (substring string escape end)))))
+ (apply string-append
+ (reverse! (cons (substring string start end)
+ output)))))))))
+
+(define format-methods '())
+
+(define (define-format-method ctl-char method)
+ ;; Associate a formatting method `method' with `ctl-char' -- the
+ ;; control-char of the directive that should invoke this method.
+ ;; `method' is called with the arguments of the format directive
+ ;; (flags, width, precision), the remaining format arguments, and a
+ ;; continuation. The continuation should be called with the
+ ;; resulting output string and the format args that weren't used.
+ ;; The values that can be expected of flags, width, and precision
+ ;; are described by `parse-format-directive'.
+ (set! format-methods (cons (cons ctl-char method)
+ (del-assq! ctl-char format-methods))))
+
+(define-format-method #\%
+ (lambda (flags width precision format-args continue)
+ flags width precision ; just ignore any modifiers
+ (continue "%" format-args)))
+
+(define (define-1arg-format-method ctl-char procedure)
+ ;; Define a format method given a procedure that expects 1 argument and
+ ;; returns a string.
+ ;; If max or min is '*, also expects integers for these.
+ (define-format-method ctl-char
+ (lambda (flags width precision format-args continue)
+ (guarantee-integer-modifier
+ width format-args
+ (lambda (width args)
+ (guarantee-integer-modifier
+ precision args
+ (lambda (precision args)
+ (let ((args (guarantee-another-arg args)))
+ (continue
+ (procedure flags width precision (car args))
+ (cdr args))))))))))
+
+(define-1arg-format-method #\s
+ (lambda (flags width precision format-arg)
+ (let ((str (let ((buffer (make-buffer "el:format %s scratch buffer"
+ (ref-mode-object fundamental)
+ (working-directory-pathname))))
+ (print format-arg false buffer)
+ (extract-string (buffer-start buffer) (buffer-end buffer)))))
+ ;; precision is interpreted as a maximum field size
+ (let ((str (if (and precision (> (string-length str) precision))
+ (substring str 0 precision)
+ str)))
+ (if (and width (< (string-length str) width))
+ ((if (memq 'LEFT-JUSTIFY flags) pad-on-right pad-on-left)
+ str width #\space)
+ str)))))
+
+(define-1arg-format-method #\c
+ (lambda (flags width precision format-arg)
+ flags width precision ; just ignore any modifiers
+ (cond ((integer? format-arg)
+ (string (ascii->char format-arg)))
+ (else (error:wrong-type-datum format-arg "an ELisp integer")))))
+
+(define (define-int-formatting-method ctl-char radix)
+ (define-1arg-format-method ctl-char
+ (lambda (flags width precision format-arg)
+ (if precision (error "precision modifier not implemented" ctl-char))
+ (if format-arg
+ (let* ((arg (guarantee-integer format-arg))
+ (str (string-append
+ (if (memq 'INDICATE-RADIX flags)
+ (case radix
+ ((8) "0")
+ ((16) "0x")
+ (else ""))
+ "")
+ (number->string arg radix))))
+ (let ((str (string-append
+ (if (and (memq 'REQUIRE-SIGN flags)
+ (positive? arg))
+ "+"
+ "")
+ str)))
+ (if width
+ ((if (memq 'LEFT-JUSTIFY flags) pad-on-right pad-on-left)
+ str width
+ (if (memq 'ZERO-PADDING flags) #\0 #\space))
+ str)))
+ ;; Believe it or not, Emacs won't balk at a null integer
+ ;; argument. And GNUS relies on this fact when initializing
+ ;; the Article buffer's modeline (while gnus-current-article
+ ;; is null).
+ ""
+ ))))
+
+(define-int-formatting-method #\d 10)
+(define-int-formatting-method #\o 8)
+(define-int-formatting-method #\x 16)
+
+(define (guarantee-another-arg args)
+ (if (pair? args)
+ args
+ (guarantee-another-arg
+ (error:%signal Qerror
+ "Format string wants too many arguments"))))
+
+(define (guarantee-integer-modifier width args receiver)
+ ;; Tail-call receiver with integer width (or false) and remaining
+ ;; format args.
+ (cond ((eq? width '*)
+ (let ((args (guarantee-another-arg args)))
+ (receiver (guarantee-integer (car args))
+ (cdr args))))
+ ((eq? width false)
+ (receiver false args))
+ (else
+ (receiver (guarantee-integer width)
+ args))))
+
+(define (pad-on-right string n #!optional pad-char)
+ ;; copied from edwin/strpad.scm; modified to take pad-char parameter
+ (let ((pad-char (if (default-object? pad-char) #\space pad-char))
+ (l (string-length string)))
+ (if (> n l)
+ (let ((result (string-allocate n)))
+ (substring-move-right! string 0 l result 0)
+ (substring-fill! result l n pad-char)
+ result)
+ string)))
+
+(define (pad-on-left string n #!optional pad-char)
+ ;; copied from edwin/strpad.scm; modified to take pad-char parameter
+ (let ((pad-char (if (default-object? pad-char) #\space pad-char))
+ (l (string-length string)))
+ (let ((delta (- n l)))
+ (if (positive? delta)
+ (let ((result (string-allocate n)))
+ (substring-fill! result 0 delta pad-char)
+ (substring-move-right! string 0 l result delta)
+ result)
+ string))))
+
+(define (guarantee-integer object)
+ (if (integer? object)
+ object
+ (guarantee-integer
+ (error:wrong-type-datum object "an integer"))))
+\f
+(DEFUN (el:char-equal c1 c2)
+ "T if args (both characters (numbers)) match. May ignore case.
+Case is ignored if the current buffer specifies to do so."
+ (let ((c1 (CHECK-CHAR c1))
+ (c2 (CHECK-CHAR c2)))
+ (if (null? (%symbol-value Qcase-fold-search))
+ (char=? c1 c2)
+ (string=? (string-downcase (char->string c1))
+ (string-downcase (char->string c2))))))
+
+(DEFUN (el:getenv var)
+ "Return the value of environment variable VAR, as a string.
+VAR should be a string. If the environment variable VAR is not defined,
+the value is nil."
+ (let* ((var (CHECK-STRING var))
+ (val (get-environment-variable var)))
+ (if (not val)
+ '()
+ val)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+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
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved |#
+
+;;;; 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))
+
+(define-package (elisp subrs)
+ (files "Subrs")
+ (parent (elisp))
+ (export (elisp)
+ %subr?
+ %make-subr
+ %subr-docstring
+ %subr-name
+ %subr-procedure
+ %subr-prompt
+ %subr-special-form?))
+
+(define-package (elisp symbols)
+ (files "Symbols")
+ (parent (elisp))
+ (export (elisp)
+ %symbol?
+ %make-symbol
+ %symbol-name
+ %symbol-function
+ %set-symbol-function!
+ %symbol-fbound?
+ %set-symbol-funbound!
+ %symbol-plist
+ %set-symbol-plist!
+ %get
+ %put!
+ %symbol-command
+ %set-symbol-command!
+ %symbol-bound?
+ %set-symbol-unbound!
+ %symbol-value
+ %set-symbol-value!
+ %symbol-default
+ %set-symbol-default!
+ %make-variable-buffer-local!
+ %make-local-variable!
+ %kill-local-variable!
+ initial-obarray
+ %intern
+ %intern-soft
+ %for-symbol
+ %make-symbol-variable!
+ %make-symbol-generic!
+ boolean-getter
+ boolean-setter
+ boolean-default-getter
+ boolean-default-setter
+ default-getter
+ default-setter
+ constant-getter
+ constant-setter
+ unimplemented-getter
+ unimplemented-setter
+ Qnil
+ Qt
+ Qsetting-constant
+ Qvariable-documentation))
+
+(define-package (elisp buffers)
+ (files "Buffers")
+ (parent (elisp))
+ (export (elisp)
+ %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
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved |#
+
+(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))))
+ (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)))
+
+(cref2/generate-cref-unusual "elisp")
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Evaluator for GNU Emacs Lisp interpreter.
+
+Notes: interactive-p was punted. It always returns T for now. It's unclear how
+to get the correct behavior. All (five) uses in GNU Emacs 18.58 lisp/, should
+be compatible with this behavior. |#
+
+(declare (usual-integrations))
+\f
+(define Qand-optional (%intern "&optional" initial-obarray))
+(define Qand-rest (%intern "&rest" initial-obarray))
+;(define Qerror-conditions (%intern "error-conditions" initial-obarray))
+;(define Qinteractive (%intern "interactive" initial-obarray))
+;(define Qinvalid-function (%intern "invalid-function" initial-obarray))
+(%put! Qinvalid-function Qerror-conditions (list Qinvalid-function Qerror))
+(%put! Qinvalid-function Qerror-message "Invalid function")
+;(define Qlambda (%intern "lambda" initial-obarray))
+(define Qmacro (%intern "macro" initial-obarray))
+;(define Qnil (%intern "nil" initial-obarray))
+;(define Qno-catch (%intern "no-catch" initial-obarray))
+(%put! Qno-catch Qerror-conditions (list Qno-catch Qerror))
+(%put! Qno-catch Qerror-message "No catch for tag")
+;(define Qt (%intern "t" initial-obarray))
+;(define Qvariable-documentation
+; (%intern "variable-documentation" initial-obarray))
+;(define Qwrong-number-of-arguments
+; (%intern "wrong-number-of-arguments" initial-obarray))
+(%put! Qwrong-number-of-arguments Qerror-conditions
+ (list Qwrong-number-of-arguments Qerror))
+(%put! Qwrong-number-of-arguments Qerror-message "Wrong number of arguments")
+\f
+(DEFUN (el:or "e . args)
+ "Eval args until one of them yields non-NIL, then return that value.
+The remaining args are not evalled at all.
+If all args return NIL, return NIL."
+ (if (pair? args)
+ (or (el:eval (car args))
+ (apply el:or (cdr args)))
+ '()))
+
+(DEFUN (el:and "e . args)
+ "Eval args until one of them yields NIL, then return NIL.
+The remaining args are not evalled at all.
+If no arg yields NIL, return the last arg's value."
+ (if (pair? args)
+ (let loop ((args args))
+ (let ((value (el:eval (car args)))
+ (rest (cdr args)))
+ (if (null? value)
+ '()
+ (if (pair? rest)
+ (loop rest)
+ value))))
+ Qt))
+
+(DEFUN (el:if "e c t . e)
+ "(if C T E...) if C yields non-NIL do T, else do E...
+Returns the value of T or the value of the last of the E's.
+There may be no E's; then if C yields NIL, the value is NIL."
+ (let ((condition (el:eval c)))
+ (if (null? condition)
+ (apply el:progn e)
+ (el:eval t))))
+
+(DEFUN (el:cond "e . clauses)
+ "(cond CLAUSES...) tries each clause until one succeeds.
+Each clause looks like (C BODY...). C is evaluated
+and, if the value is non-nil, this clause succeeds:
+then the expressions in BODY are evaluated and the last one's
+value is the value of the cond expression.
+If a clause looks like (C), C's value if non-nil is returned from cond.
+If no clause succeeds, cond returns nil."
+ (if (null? clauses)
+ 1 ; Weird huh? (per GNU Emacs 18.58)
+ (let loop ((clauses clauses))
+ (if (null? clauses)
+ '()
+ (let ((clause (car clauses)))
+ (let ((val (el:eval (car clause))))
+ (if (null? val)
+ (loop (cdr clauses))
+ (if (null? (cdr clause))
+ val
+ (apply el:progn (cdr clause))))))))))
+
+(DEFUN (el:progn "e . args)
+ "Eval arguments in sequence, and return the value of the last one."
+ (if (null? args)
+ '()
+ (if (null? (cdr args))
+ (el:eval (car args))
+ (begin
+ (el:eval (car args))
+ (apply el:progn (cdr args))))))
+
+(DEFUN (el:prog1 "e . args)
+ "Eval arguments in sequence, then return the FIRST arg's value.
+This value is saved during the evaluation of the remaining args,
+whose values are discarded."
+ (if (null? args)
+ '()
+ (let ((val (el:eval (car args))))
+ (apply el:progn (cdr args))
+ val)))
+
+(DEFUN (el:prog2 "e . args)
+ "Eval arguments in sequence, then return the SECOND arg's value.
+This value is saved during the evaluation of the remaining args,
+whose values are discarded."
+ (if (null? args)
+ '()
+ (begin
+ (el:eval (car args))
+ (if (null? (cdr args))
+ '()
+ (let ((val (el:eval (cadr args))))
+ (apply el:progn (cddr args))
+ val)))))
+
+(DEFUN (el:setq "e . args)
+ "(setq SYM VAL SYM VAL ...) sets each SYM to the value of its VAL.
+The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.
+Each SYM is set before the next VAL is computed."
+ (cond ((null? args) '())
+ ((pair? args)
+ (let ((sym (CHECK-SYMBOL (car args)))
+ (val-rest (cdr args)))
+ (let ((val (cond ((null? val-rest) '())
+ ((not (pair? val-rest))
+ (wrong-type-argument Qlistp val-rest))
+ (else
+ (el:eval (car val-rest))))))
+ (%set-symbol-value! sym val)
+ (if (or (null? val-rest) (null? (cdr val-rest)))
+ val
+ (apply el:setq (cdr val-rest))))))))
+
+(DEFUN (el:quote "e . args)
+ "Return the argument, without evaluating it. (quote x) yields x."
+ (car args))
+
+(DEFUN (el:function "e . args)
+ "Quote a function object.
+Equivalent to the quote function in the interpreter,
+but causes the compiler to compile the argument as a function
+if it is not a symbol."
+ (car args))
+
+(DEFUN (el:interactive-p)
+ "Return t if function in which this appears was called interactively.
+This means that the function was called with call-interactively (which
+includes being called as the binding of a key)
+and input is currently coming from the keyboard (not in keyboard macro).
+
+NOTE: This function always returns t in Edwin."
+ #|(if (el:and (%symbol-value Qexecuting-macro)
+ (if noninteractive? '() Qt))
+ Qt '())|#
+ Qt)
+
+(DEFUN (el:defun "e fn-name . args)
+ "(defun NAME ARGLIST [DOCSTRING] BODY...) defines NAME as a function.
+The definition is (lambda ARGLIST [DOCSTRING] BODY...).
+See also the function interactive ."
+ (let ((function (cons Qlambda args))
+ (fn-name (CHECK-SYMBOL fn-name)))
+ (%fset! fn-name function)
+ (%make-edwin-command fn-name function)
+ fn-name))
+
+(define (%make-edwin-command symbol function)
+ (let ((spec (%function-interactive-specification function)))
+ (if (and spec
+ (or (%symbol-command symbol)
+ (not (string-table-get editor-commands
+ (%symbol-name symbol)))))
+ (let ((command
+ (make-command (intern (%symbol-name symbol))
+ ;; Take our chances with the current buffer.
+ (el:substitute-command-keys
+ (%function-documentation-string function))
+ (lambda ()
+ ;; These are recorded by Edwin normally.
+ (%interactive-arguments symbol false))
+ (lambda args
+ (%apply-interactively
+ ;; Ignore Emacs Lisp notion of the
+ ;; current buffer. Command dispatch
+ ;; is supposed to set this to the
+ ;; buffer of the selected window, i.e.
+ ;; (current-buffer).
+ (current-buffer) symbol args)))))
+ (%set-symbol-command! symbol command)
+ command)))
+ unspecific)
+
+(DEFUN (el:defmacro "e fn-name . args)
+ "(defmacro NAME ARGLIST [DOCSTRING] BODY...) defines NAME as a macro.
+The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
+When the macro is called, as in (NAME ARGS...),
+the function (lambda ARGLIST BODY...) is applied to
+the list ARGS... as it appears in the expression,
+and the result should be a form to be evaluated instead of the original."
+ (%fset! fn-name (cons Qmacro (cons Qlambda args)))
+ fn-name)
+
+(DEFUN (el:defvar "e sym #!optional init doc)
+ "(defvar SYMBOL INITVALUE DOCSTRING) defines SYMBOL as an advertised variable.
+INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
+INITVALUE and DOCSTRING are optional.
+If DOCSTRING starts with *, this variable is identified as a user option.
+ This means that M-x set-variable and M-x edit-options recognize it.
+If INITVALUE is missing, SYMBOL's value is not set."
+ (let ((sym (CHECK-SYMBOL sym)))
+ (if (and (not (%symbol-bound? sym))
+ (not (default-object? init)))
+ (begin
+ (%set-symbol-value! sym (el:eval init))
+ (if (not (default-object? doc))
+ (%put! sym Qvariable-documentation doc))))
+ sym))
+
+(DEFUN (el:defconst "e sym init #!optional doc)
+ "(defconst SYMBOL INITVALUE DOCSTRING) defines SYMBOL as a constant variable.
+The intent is that programs do not change this value (but users may).
+Always sets the value of SYMBOL to the result of evalling INITVALUE.
+DOCSTRING is optional.
+If DOCSTRING starts with *, this variable is identified as a user option.
+ This means that M-x set-variable and M-x edit-options recognize it."
+ (let ((sym (CHECK-SYMBOL sym)))
+ (if (not (default-object? doc))
+ (%put! sym Qvariable-documentation doc))
+ (if (not (eq? (%symbol-bound? sym) 'EDWIN))
+ (%set-symbol-value! sym (el:eval init)))
+ sym))
+
+(DEFUN (el:user-variable-p var)
+ "Returns t if VARIABLE is intended to be set and modified by users,
+as opposed to by programs.
+Determined by whether the first character of the documentation
+for the variable is \"*\""
+ (if (char=? (string-ref (%get (CHECK-SYMBOL var) Qvariable-documentation) 0)
+ #\*)
+ Qt '()))
+
+(DEFUN (el:let "e varlist . body)
+ "(let* VARLIST BODY...) binds variables according to VARLIST then executes BODY.
+The value of the last form in BODY is returned.
+Each element of VARLIST is a symbol (which is bound to NIL)
+or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
+Each VALUEFORM can refer to the symbols already bound by this VARLIST."
+ (if (null? varlist)
+ (apply el:progn body)
+ (varlist-receiver
+ varlist
+ (lambda (vars inits)
+ (%specbind vars inits (lambda () (apply el:progn body)))))))
+
+(DEFUN (el:let* "e varlist . body)
+ "(let VARLIST BODY...) binds variables according to VARLIST then executes BODY.
+The value of the last form in BODY is returned.
+Each element of VARLIST is a symbol (which is bound to NIL)
+or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
+All the VALUEFORMs are evalled before any symbols are bound."
+ (let loop ((varlist varlist))
+ (if (null? varlist)
+ (apply el:progn body)
+ (varlist-receiver
+ (list (el:car varlist))
+ (lambda (vars inits)
+ (%specbind vars inits (lambda () (loop (el:cdr varlist)))))))))
+
+(define (varlist-receiver varlist receiver)
+ (let loop ((varlist varlist) (vars '()) (inits '()))
+ (if (null? varlist)
+ (receiver vars inits)
+ (let ((elt (el:car varlist)))
+ (if (%symbol? elt)
+ (loop (cdr varlist)
+ (cons elt vars)
+ (cons '() inits))
+ (loop (cdr varlist)
+ (cons (el:car elt) vars)
+ (cons (el:eval (el:car (el:cdr elt))) inits)))))))
+
+(define (%specbind vars inits thunk)
+ (let ((current-buffer (%current-buffer))
+ (inside-state inits)
+ (outside-state)
+ (+unbound+ "unbound"))
+ (let ((safe-value
+ (lambda (sym)
+ (if (%symbol-bound? sym) (%symbol-value sym) +unbound+)))
+ (safe-set!
+ (lambda (sym val)
+ (if (eq? val +unbound+)
+ (%set-symbol-unbound! sym)
+ (%set-symbol-value! sym val)))))
+ (dynamic-wind
+ (lambda ()
+ ;; When rewinding, (%current-buffer) may not be the same as
+ ;; current-buffer, so set it before establishing bindings and
+ ;; restore it afterwards.
+ (let ((old-buffer (%current-buffer)))
+ (%set-current-buffer! current-buffer)
+ (set! outside-state (map safe-value vars))
+ (%set-current-buffer! old-buffer))
+ (for-each safe-set! vars inside-state)
+ (set! inside-state)
+ unspecific)
+ thunk
+ (lambda ()
+ ;; After (thunk), (%current-buffer) may be anything, so set and
+ ;; restore it here too.
+ (let ((old-buffer (%current-buffer)))
+ (%set-current-buffer! current-buffer)
+ (set! inside-state (map safe-value vars))
+ (%set-current-buffer! old-buffer))
+ (for-each safe-set! vars outside-state)
+ (set! outside-state)
+ unspecific)))))
+
+(DEFUN (el:while "e test . body)
+ "(while TEST BODY...) if TEST yields non-NIL, execute the BODY forms and repeat."
+ (if (null? (el:eval test))
+ '()
+ (begin
+ (apply el:progn body)
+ (apply el:while test body))))
+
+(DEFUN (el:macroexpand form #!optional env)
+ "If FORM is a macro call, expand it.
+If the result of expansion is another macro call, expand it, etc.
+Return the ultimate expansion.
+The second optional arg ENVIRONMENT species an environment of macro
+definitions to shadow the loaded ones for use in file byte-compilation."
+
+ (define (symbol-macro sym env)
+ (let ((tem (el:assq sym env)))
+ (if (null? tem)
+ (let ((def (%symbol-function sym)))
+ (if (%symbol? def)
+ (symbol-macro def env)
+ def))
+ (let ((def (el:cdr tem)))
+ (if (%symbol? def)
+ (symbol-macro def env)
+ (cons Qmacro def))))))
+
+ (if (not (pair? form))
+ form
+ (if (not (%symbol? (car form)))
+ form
+ (let ((def (symbol-macro (car form)
+ (if (default-object? env) '() env))))
+ (cond ((not (pair? def))
+ form)
+ ((eq? (car def) Qautoload)
+ (if (el:car (el:nthcdr 4 def))
+ (begin
+ (do-autoload def (car form))
+ (el:macroexpand form env))
+ form))
+ ((eq? (car def) Qmacro)
+ (el:macroexpand (el:apply (cdr def) (cdr form)) env))
+ (else form))))))
+
+(define condition-type:%throw
+ (make-condition-type 'el:throw () '(TAG VALUE) "emacs lisp throw"))
+
+(define error:%throw
+ (condition-signaller
+ condition-type:%throw '(TAG VALUE)
+ (lambda (condition)
+ (error:%signal Qno-catch (list (access-condition condition 'TAG)
+ (access-condition condition 'VALUE))))))
+
+(DEFUN (el:catch "e tag . body)
+ "(catch TAG BODY...) perform BODY allowing nonlocal exits using (throw TAG).
+TAG is evalled to get the tag to use. throw to that tag exits this catch.
+Then the BODY is executed. If no throw happens, the value of the last BODY
+form is returned from catch. If a throw happens, it specifies the value to
+return from catch."
+ (%catch (el:eval tag) (lambda () (apply el:progn body))))
+
+(define (%catch tag thunk)
+ (call-with-current-continuation
+ (lambda (exit)
+ (bind-condition-handler
+ (list condition-type:%throw)
+ (lambda (condition)
+ (if (eq? (access-condition condition 'TAG) tag)
+ (exit (access-condition condition 'VALUE))))
+ thunk))))
+
+(DEFUN (el:throw tag value)
+ "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.
+Both TAG and VALUE are evalled."
+ (error:%throw tag value))
+
+(DEFUN (el:unwind-protect "e bodyform . unwindforms)
+ "Do BODYFORM, protecting with UNWINDFORMS.
+Usage looks like (unwind-protect BODYFORM UNWINDFORMS...)
+If BODYFORM completes normally, its value is returned
+after executing the UNWINDFORMS.
+If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway."
+ (%unwind-protect
+ (lambda () (el:eval bodyform))
+ (lambda () (apply el:progn unwindforms))))
+
+(define (%unwind-protect protected-thunk unwind-thunk)
+ (dynamic-wind
+ (lambda () unspecific)
+ protected-thunk
+ unwind-thunk))
+
+(define condition-type:%signal
+ (make-condition-type 'EL:SIGNAL () '(NAME DATA)
+ (lambda (condition port)
+ (write-string "emacs lisp signal " port)
+ (write-string (%symbol-name (access-condition condition 'NAME)) port)
+ (write-string ": " port)
+ (write (access-condition condition 'DATA) port))))
+
+(define (unhandled-signal-handler condition)
+ (let ((message (or (let ((sym (access-condition condition 'NAME)))
+ (and (%symbol? sym)
+ (%get sym Qerror-message)))
+ "peculiar error"))
+ (data (access-condition condition 'DATA)))
+ (if (pair? data)
+ (apply editor-error
+ message ": "
+ (el:prin1-to-string (car data))
+ (append-map!
+ (lambda (datum)
+ (list ", " (el:prin1-to-string datum)))
+ (cdr data)))
+ (editor-error message))))
+
+(define error:%signal
+ (condition-signaller condition-type:%signal '(NAME DATA)
+ unhandled-signal-handler))
+
+(DEFUN (el:condition-case "e var bodyform . handlers)
+ "Regain control when an error is signaled.
+ (condition-case VAR BODYFORM HANDLERS...)
+executes BODYFORM and returns its value if no error happens.
+Each element of HANDLERS looks like (CONDITION-NAME BODY...)
+where the BODY is made of Lisp expressions.
+The handler is applicable to an error
+if CONDITION-NAME is one of the error's condition names.
+When a handler handles an error,
+control returns to the condition-case and the handler BODY... is executed
+with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
+The value of the last BODY form is returned from the condition-case.
+See SIGNAL for more info."
+ (call-with-current-continuation
+ (lambda (exit)
+ (bind-condition-handler
+ (list condition-type:%signal)
+ (lambda (condition)
+ (let ((generalizations (%get (access-condition condition 'NAME)
+ Qerror-conditions)))
+ (let loop ((handlers handlers))
+ (cond ((null? handlers) false)
+ ((memq (caar handlers) generalizations)
+ (exit (if (null? var)
+ (apply el:progn (CHECK-LIST (cdar handlers)))
+ (%specbind
+ (list var)
+ (list (cons
+ (access-condition condition 'NAME)
+ (access-condition condition 'DATA)))
+ (lambda ()
+ (apply el:progn
+ (CHECK-LIST (cdar handlers))))))))
+ (else (loop (cdr handlers)))))))
+ (lambda ()
+ (el:eval bodyform))))))
+
+(DEFUN (el:signal name data)
+ "Signal an error. Args are SIGNAL-NAME, and associated DATA.
+A signal name is a symbol with an error-conditions property
+that is a list of condition names.
+A handler for any of those names will get to handle this signal.
+The symbol error should always be one of them.
+
+DATA should be a list. Its elements are printed as part of the error message.
+If the signal is handled, DATA is made available to the handler.
+See condition-case."
+ (error:%signal name data))
+
+(DEFUN (el:commandp function)
+ "T if FUNCTION makes provisions for interactive calling.
+This means it contains a description for how to read arguments to give it.
+The value is nil for an invalid function or a symbol with no function definition.
+
+Interactively callable functions include strings (treated as keyboard macros),
+lambda-expressions that contain a top-level call to interactive ,
+autoload definitions made by autoload with non-nil fourth argument,
+and some of the built-in functions of Lisp.
+
+Also, a symbol is commandp if its function definition is commandp."
+ (let* ((unbound "Unbound")
+ (fun (let loop ((fun function) (i 1))
+ (cond ((not (%symbol? fun)) fun)
+ ((> i 10) unbound)
+ ((%symbol-fbound? fun)
+ (loop (%symbol-function fun) (1+ i)))
+ (else unbound)))))
+ (cond ((eq? fun unbound) false)
+ ((%subr? fun) (not (null? (%subr-prompt fun))))
+ ;; Substituting comtab? for vector?, since Emacs Lisp
+ ;; emulator doesn't grok vectors as keymaps...
+ ;;((vector? fun) true)
+ ((comtab? fun) true)
+ ((string? fun) true)
+ ((not (pair? fun)) false)
+ (else
+ (let ((funcar (car fun)))
+ (cond ((not (%symbol? funcar))
+ (error:%signal Qinvalid-function (list fun)))
+ ((eq? Qlambda funcar)
+ (not (null? (el:assq Qinteractive (cdr (cdr fun))))))
+ ((eq? Qautoload funcar)
+ (eq? Qt (el:car (el:cdr (el:cdr (el:cdr fun))))))
+ (else '())))))))
+
+(DEFUN (el:autoload function file #!optional docstring interactive macro_)
+ "Define FUNCTION to autoload from FILE.
+FUNCTION is a symbol; FILE is a file name string to pass to load.
+Third arg DOCSTRING is documentation for the function.
+Fourth arg INTERACTIVE if non-nil says function can be called interactively.
+Fifth arg MACRO if non-nil says the function is really a macro.
+Third through fifth args give info about the real definition.
+They default to nil.
+If FUNCTION is already defined other than as an autoload,
+this does nothing and returns nil."
+ (let ((sym (CHECK-SYMBOL function))
+ (file (CHECK-STRING file)))
+ (if (or (not (%symbol-fbound? sym))
+ (let ((fun (%symbol-function sym)))
+ (and (pair? fun) (eq? (car fun) Qautoload))))
+ (let ((function
+ (list Qautoload
+ file
+ (if (default-object? docstring) false docstring)
+ (if (default-object? interactive) false interactive)
+ (if (default-object? macro_) false macro_))))
+ (%fset! sym function)
+ (if (not (either-default? interactive))
+ (%make-edwin-command sym function)))))
+ '())
+
+(define autoload-queue Qt)
+
+(define (do-autoload fundef funname)
+ (protect-with-autoload-queue
+ (lambda ()
+ (el:load (cadr fundef)
+ '()
+ '() ;(if noninteractive? Qt '())
+ '())))
+ (let ((val (%function* funname)))
+ (if (and (pair? val)
+ (eq? (car val) Qautoload))
+ (error:%signal
+ Qerror
+ (list (el:format "Autoloading failed to define function %s"
+ funname)))))
+ unspecific)
+
+(define (protect-with-autoload-queue thunk)
+ (define (exchange!)
+ ;; For each entry in queue, exchange current value with saved value.
+ (let loop ((queue autoload-queue))
+ (cond ((eq? queue Qt) unspecific)
+ ((and (pair? queue) (pair? (car queue)))
+ (let ((first (caar queue))
+ (second (cdar queue)))
+ (if (null? second)
+ (begin
+ (set-car! (car queue) (%symbol-value Qfeatures))
+ (%set-symbol-value! Qfeatures first))
+ (begin
+ (set-cdr! (car queue) (%symbol-function first))
+ (%set-symbol-function! first second)))
+ (loop (cdr queue))))
+ (else (set! autoload-queue
+ (error:wrong-type-datum autoload-queue
+ "an alist of Emacs Lisp symbols and values, or the Emacs Lisp symbol \"t\""))
+ (loop autoload-queue)))))
+
+ (let ((outside-queue)
+ (inside-queue Qt))
+ (dynamic-wind
+ (lambda ()
+ (set! outside-queue autoload-queue)
+ (set! autoload-queue inside-queue)
+ (set! inside-queue)
+ (exchange!)
+ unspecific)
+ (lambda ()
+ (thunk)
+ (set! autoload-queue Qt))
+ (lambda ()
+ (exchange!)
+ (set! inside-queue autoload-queue)
+ (set! autoload-queue outside-queue)
+ (set! outside-queue)
+ unspecific))))
+
+(DEFUN (el:eval form)
+ "Evaluate FORM and return its value."
+ (cond ((%symbol? form)
+ (%symbol-value form))
+ ((not (pair? form))
+ form)
+ (else
+ (let ((original-fun (car form))
+ (original-args (cdr form)))
+ (let loop ((fun (%function* original-fun)))
+ (cond ((%subr? fun)
+ (if (%subr-special-form? fun)
+ (apply fun original-args)
+ (apply fun (%map el:eval original-args))))
+ ((not (and (pair? fun)
+ (%symbol? (car fun))))
+ (loop (%function*
+ (error:%signal Qinvalid-function (list fun)))))
+ ((eq? (car fun) Qlambda)
+ (funcall-lambda fun (%map el:eval original-args)))
+ ((eq? (car fun) Qmacro)
+ (el:eval (el:apply (cdr fun) original-args)))
+ ((eq? (car fun) Qautoload)
+ (do-autoload fun original-fun)
+ (loop (%function* original-fun)))
+ (else
+ (error:%signal Qinvalid-function (list fun)))))))))
+
+(DEFUN (el:apply fun . args)
+ "Call FUNCTION, passing remaining arguments to it. The last argument
+is a list of arguments to pass.
+Thus, (apply '+ 1 2 '(3 4)) returns 10."
+ (apply el:funcall fun (append! (except-last-pair args)
+ (car (last-pair args)))))
+
+(DEFUN (el:funcall func . args)
+ "Call first argument as a function, passing remaining arguments to it.
+Thus, (funcall 'cons 'x 'y) returns (x . y)."
+ (let retry ((fun (%function* func))
+ (numargs (length args)))
+ (cond ((%subr? fun)
+ (cond ((%subr-special-form? fun)
+ (el:apply (error:%signal Qinvalid-function (list fun))
+ args))
+ ((not (procedure-arity-valid? fun numargs))
+ (el:apply (error:%signal Qwrong-number-of-arguments
+ (list numargs))
+ args))
+ (else (apply fun args))))
+ ((not (and (pair? fun)
+ (%symbol? (car fun))))
+ (error:%signal Qinvalid-function (list fun)))
+ ((eq? (car fun) Qlambda)
+ (funcall-lambda fun args))
+ ((eq? (car fun) Qautoload)
+ (do-autoload fun func)
+ (retry (%function* func) numargs))
+ (else
+ (error:%signal Qinvalid-function (list fun))))))
+
+(define (funcall-lambda fun orig-args)
+ (let loop ((syms (car (cdr fun)))
+ (args orig-args)
+ (optional? false)
+ (vars ())
+ (inits ()))
+ (cond ((null? syms)
+ (if (not (null? args))
+ (error:%signal Qwrong-number-of-arguments
+ (list fun (length orig-args))))
+ (%specbind vars inits
+ (lambda () (apply el:progn (cdr (cdr fun))))))
+ ((eq? (car syms) Qand-rest)
+ (loop (cdr (cdr syms))
+ ()
+ optional?
+ (cons (CHECK-SYMBOL (car (cdr syms))) vars)
+ (cons args inits)))
+ ((eq? (car syms) Qand-optional)
+ (loop (cdr syms) args #!true vars inits))
+ ((not (null? args))
+ (loop (cdr syms)
+ (cdr args)
+ optional?
+ (cons (CHECK-SYMBOL (car syms)) vars)
+ (cons (car args) inits)))
+ ((not optional?)
+ (error:%signal Qwrong-number-of-arguments
+ (list fun (length orig-args))))
+ (else ; args exhausted, but optional anyway
+ (loop (cdr syms)
+ ()
+ #!true
+ (cons (CHECK-SYMBOL (car syms)) vars)
+ (cons '() inits))))))
+\f
+;;;; Operations on functions.
+
+(define (%function* obj)
+ (if (%symbol? obj)
+ (if (%symbol-fbound? obj)
+ (%function* (%symbol-function obj))
+ (%function* (error:%signal Qvoid-function (list obj))))
+ obj))
+
+(define (%function-interactive-specification function)
+ ;; Returns false (null) only if the function has no interactive
+ ;; specification. If the function was declared with an
+ ;; `interactive' expression in its body and the expression contains
+ ;; no specification, the null-string is returned.
+ (let loop ((function function))
+ (cond ((%subr? function)
+ (%subr-prompt function))
+ ((%symbol? function)
+ (if (%symbol-fbound? function)
+ (loop (%symbol-function function))
+ false))
+ ((and (pair? function)
+ (eq? (car function) Qlambda)
+ (pair? (cdr function))
+ (el:assq Qinteractive (cdr (cdr function))))
+ => (lambda (interactive-form)
+ (if (pair? (cdr interactive-form))
+ (cadr interactive-form)
+ "")))
+ ((and (pair? function)
+ (eq? (car function) Qautoload)
+ (list? function)
+ (= (length function) 5))
+ (if (null? (cadddr function))
+ false
+ (cadddr function)))
+ (else false))))
+
+(define (%function-documentation-string function)
+ (let loop ((function function))
+ (cond ((%subr? function)
+ (%subr-docstring function))
+ ((%symbol? function)
+ (loop (%symbol-function function)))
+ ((and (pair? function)
+ (eq? (car function) Qlambda)
+ (pair? (cdr function)))
+ (let ((body (cddr function)))
+ (if (string? (car body))
+ (car body)
+ false)))
+ (else false))))
+\f
+;;;; Utility procedures
+
+(define (%map proc list)
+ ;; Scheme's `map' doesn't apply `proc' to the elements of `list' in
+ ;; any particular order...
+ (reverse!
+ (let loop ((list list)
+ (results '()))
+ (if (pair? list)
+ (loop (cdr list)
+ (cons (proc (car list)) results))
+ results))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+File IO for GNU Emacs.
+
+Note: filename operations only work for UN*X. |#
+
+(declare (usual-integrations))
+\f
+(define Qfile-error (%intern "file-error" initial-obarray))
+(%put! Qfile-error Qerror-conditions (list Qfile-error Qerror))
+(%put! Qfile-error Qerror-message "File error")
+(define Qfile-already-exists (%intern "file-already-exists" initial-obarray))
+(%put! Qfile-already-exists Qerror-conditions
+ (list Qfile-already-exists Qfile-error Qerror))
+(%put! Qfile-already-exists Qerror-message "File already exists")
+
+(DEFVAR Qinsert-default-directory
+ Qt
+ "*Non-nil means when reading a filename start with default dir in minibuffer.")
+
+(DEFVAR Qvms-stmlf-recfm
+ '()
+ "*Non-nil means write new files with record format `stmlf'.
+nil means use format `var'. This variable is meaningful only on VMS.")
+\f
+(DEFUN (el:file-name-directory file)
+ "Return the directory component in file name NAME.
+Return nil if NAME does not include a directory.
+Otherwise returns a directory spec.
+Given a Unix syntax file name, returns a string ending in slash;
+on VMS, perhaps instead a string ending in :, ] or >."
+ (let* ((file (CHECK-STRING file))
+ (slash (string-find-previous-char file #\/)))
+ (and slash
+ (substring file 0 (1+ slash)))))
+
+#| Tests for el:file-name-directory.
+
+ (el:file-name-directory "foo") => '()
+ (el:file-name-directory "") => '()
+ (el:file-name-directory "foo/bar/baz") => "foo/bar/"
+ (el:file-name-directory "foo/bar/") => "foo/bar/"
+ (el:file-name-directory "/") => "/"
+|#
+
+(DEFUN (el:file-name-nondirectory file)
+ "Return file name NAME sans its directory.
+For example, in a Unix-syntax file name,
+this is everything after the last slash,
+or the entire name if it contains no slash."
+ (let* ((file (CHECK-STRING file))
+ (slash (string-find-previous-char file #\/)))
+ (if slash
+ (substring file (1+ slash) (string-length file))
+ file)))
+
+#| Tests for el:file-name-nondirectory.
+
+ (el:file-name-nondirectory "foo") => "foo"
+ (el:file-name-nondirectory "") => ""
+ (el:file-name-nondirectory "foo/bar/baz") => "baz"
+ (el:file-name-nondirectory "foo/bar/") => ""
+ (el:file-name-nondirectory "/") => ""
+|#
+
+(DEFUN (el:file-name-as-directory file)
+ "Return a string representing file FILENAME interpreted as a directory.
+This string can be used as the value of default-directory
+or passed as second argument to expand-file-name.
+For a Unix-syntax file name, just appends a slash.
+On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc."
+ (let* ((file (CHECK-STRING file))
+ (length (string-length file)))
+ (if (or (zero? length)
+ (not (char=? #\/ (string-ref file (-1+ length)))))
+ (string-append file "/")
+ file)))
+
+#| Tests for el:file-name-as-directory.
+
+ (el:file-name-as-directory "foo") => "foo/"
+ (el:file-name-as-directory "") => "/"
+ (el:file-name-as-directory "foo/bar/baz") => "foo/bar/baz/"
+ (el:file-name-as-directory "foo/bar/") => "foo/bar/"
+ (el:file-name-as-directory "/") => "/"
+|#
+
+(DEFUN (el:directory-file-name directory)
+ "Returns the file name of the directory named DIR.
+This is the name of the file that holds the data for the directory DIR.
+In Unix-syntax, this just removes the final slash.
+On VMS, given a VMS-syntax directory name such as \"[X.Y]\",
+returns a file name such as \"[X]Y.DIR.1\"."
+ (directory-file-name (CHECK-STRING directory)))
+
+(define (directory-file-name directory)
+ (let ((last-pos (-1+ (string-length directory))))
+ (if (and (> last-pos 0)
+ (char=? #\/ (string-ref directory last-pos)))
+ (substring directory 0 last-pos)
+ directory)))
+
+#| Tests for el:directory-file-name.
+
+ (el:directory-file-name "foo") => "foo"
+ (el:directory-file-name "") => ""
+ (el:directory-file-name "foo/bar/baz") => "foo/bar/baz"
+ (el:directory-file-name "foo/bar/") => "foo/bar"
+ (el:directory-file-name "/") => "/"
+|#
+
+(DEFUN (el:make-temp-name prefix)
+ "Generate temporary name (string) starting with PREFIX (a string)."
+ (string-append
+ prefix
+ (call-with-temporary-filename
+ (lambda (pathname) (file-namestring pathname)))))
+
+#| (el:make-temp-name "foo") => e.g. "fooa22196",
+ In Edwin: "_birkholz_scm0" |#
+
+(DEFUN (el:expand-file-name name #!optional default)
+ "Convert FILENAME to absolute, and canonicalize it.
+Second arg DEFAULT is directory to start with if FILENAME is relative
+ (does not start with slash); if DEFAULT is nil or missing,
+the current buffer's value of default-directory is used.
+Filenames containing . or .. as components are simplified;
+initial ~ is expanded. See also the function substitute-in-file-name."
+ (if (either-default? default)
+ (expand-file-name (CHECK-STRING 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)))))
+
+(define (expand-file-name name #!optional default)
+ ;; merge-pathnames chokes on "//" and "$", so don't use pathname operations
+ (let ((home
+ (lambda (username)
+ (string-components (expand-user-home-directory username) #\/))))
+ (let ((simplify
+ (lambda (namelist)
+ (let loop ((head ())
+ (tail namelist))
+ (if (pair? tail)
+ (let ((this (car tail)))
+ (cond
+ ;; Reset to root.
+ ((string-null? this)
+ (loop (list this) (cdr tail)))
+ ;; Pop head unless it's the root.
+ ((string=? ".." this)
+ (loop (if (or (not (pair? head))
+ (and (pair? head)
+ (string-null? (car head))))
+ (cons this head)
+ (cdr head))
+ (cdr tail)))
+ ((equal? "." this) ;Ignore
+ (loop head (cdr tail)))
+ ((string-prefix? "~" this)
+ (loop (reverse!
+ (home (substring this 1 (string-length this))))
+ (cdr tail)))
+ (else
+ (loop (cons this head) (cdr tail)))))
+ (reverse! head))))))
+
+ (let* ((namelist (string-components name #\/))
+ (dfltlist (string-components
+ (directory-file-name
+ (if (default-object? default)
+ (->namestring
+ (buffer-default-directory (%current-buffer)))
+ default))
+ #\/))
+ (name (car (last-pair namelist)))
+ (dirlist (append! dfltlist (except-last-pair! namelist))))
+ ;; Watch out for UNIX weirdness -- directory syntax in name!
+ (if (or (string-prefix? "~" name)
+ (string=? "." name)
+ (string=? ".." name))
+ (begin
+ (set! dirlist (append! dirlist (list name)))
+ (set! name ())))
+ (let ((simplified (simplify dirlist)))
+ ;;(format true "~%(simplify ~S) => ~S" dirlist simplified)
+ (string-append (components-string simplified "/")
+ (cond ((and (null? name) (equal? simplified '("")))
+ ;; Root dir with no name is not simply ""!
+ "/")
+ ((null? name)
+ ;; String-append doesn't like ().
+ "")
+ (else
+ ;; To append name, we'll need a separator.
+ (string-append "/" name)))))))))
+
+#| Tests for el:expand-file-name.
+
+ (el:expand-file-name "file/name" "/foo/bar") => "/foo/bar/file/name"
+ (el:expand-file-name "~guest/name") => "/udir/guest/name"
+ (el:expand-file-name "~/name") => "/udir/birkholz/name"
+ (el:expand-file-name "~/") => "/udir/birkholz/"
+ (el:expand-file-name "~") => "/udir/birkholz"
+ (el:expand-file-name "~guest") => "/udir/guest"
+ (el:expand-file-name "file//name" "/foo/bar") => "/name"
+ (el:expand-file-name "file/~guest/name" "/foo/bar") =>
+ "/foo/bar/file/~guest/name"!
+ (el:expand-file-name "file//~guest/name" "/foo/bar") => "/~guest/name"!
+ (el:expand-file-name "file//name/~guest/name" "/foo/bar") =>
+ "/name/~guest/name"!
+ (el:expand-file-name "file/../name/" "/foo/bar") => "/foo/bar/name/"
+ (el:expand-file-name "file/name/../../../" "/foo/bar") => "/foo/"
+ (el:expand-file-name "file/name/../../.." "/foo/bar") => "/foo"
+ (el:expand-file-name "file/name/../../../../" "/foo/bar") => "//"!
+ (el:expand-file-name "file/name/../../../.." "/foo/bar") => "/"
+ (el:expand-file-name "file/name/../../../../../" "/foo/bar") => "//"!
+ (el:expand-file-name "file/name/../../../../../" "foo/bar") => "/../"!
+ (el:expand-file-name "file/name/../../../../.." "/foo/bar") => "/"!
+ (el:expand-file-name "file/name/../../../../.." "foo/bar") => "/.."!
+ (el:expand-file-name "file/name/./../././" "/foo/bar") => "/foo/bar/file/"
+ (el:expand-file-name "file/name/./.././." "/foo/bar") => "/foo/bar/file"
+ (el:expand-file-name "file/name/./../././" "/foo/./bar/..") => "/foo/file/"
+ (el:expand-file-name "file/name/./.././." "/foo/./bar/..") => "/foo/file"
+|#
+
+(define char-set:not-alpha_numeric
+ (char-set-invert (char-set-union char-set:alphanumeric (char-set #\_))))
+
+(DEFUN (el:substitute-in-file-name string)
+ "Substitute environment variables referred to in STRING.
+A $ begins a request to substitute; the env variable name is the alphanumeric
+characters and underscores after the $, or is surrounded by braces.
+If a ~ appears following a /, everything through that / is discarded.
+On VMS, $ substitution is not done; this function does little and only
+duplicates what expand-file-name does."
+ (let ((parse-environment-variable
+ (lambda (string start values)
+ (let ((end (string-length string)))
+ (if (char=? #\{ (string-ref string (+ 1 start)))
+ (let ((close (substring-find-next-char string start end #\})))
+ (if (not close)
+ (error:%signal Qerror (list "Missing \"}\" in environment-variable substitution"))
+ (values (substring string (+ 2 start) close)
+ (+ 1 close))))
+ (let ((end (or (substring-find-next-char-in-set
+ string (+ 1 start) end
+ char-set:not-alpha_numeric)
+ end)))
+ (values (substring string (+ 1 start) end) end))))))
+ (strip
+ (lambda (string)
+ ;; strip "...//" or ".../~", leaving "/..." or "~..."
+ (let ((end (string-length string)))
+ (let loop ((start end))
+ (let ((slash (substring-find-previous-char string 0 start #\/)))
+ (cond ((not slash) string)
+ ((and (< 0 slash)
+ (char=? #\/ (string-ref string (+ -1 slash))))
+ (string-tail string slash))
+ ((and (< (+ 1 slash) start)
+ (char=? #\~ (string-ref string (+ 1 slash))))
+ (string-tail string (+ 1 slash)))
+ (else (loop slash)))))))))
+
+ (let* ((string (strip (CHECK-STRING string)))
+ (end (string-length string)))
+ (strip
+ (with-string-output-port
+ (lambda (port)
+ (let loop ((start 0))
+ (let ((dollar (substring-find-next-char string start end #\$)))
+ ;;(format true "~%substitute-in-file-name: found dollar at ~S in ~S between ~S and ~S" dollar string start end)
+ (cond ((not dollar)
+ (write-substring string start end port))
+ ((not (< dollar (+ -1 end)))
+ (error:%signal
+ Qerror
+ (list
+ "Bad format environment-variable substitution")))
+ ((char=? #\$ (string-ref string (+ 1 dollar)))
+ (write-substring string start (+ 1 dollar) port)
+ (loop (+ 2 dollar)))
+ (else
+ (write-substring string start dollar port)
+ (parse-environment-variable
+ string dollar
+ (lambda (name end-pos)
+ (let ((value (get-environment-variable name)))
+ (if (not value)
+ (error:%signal Qerror (list (el:format "Substituting nonexistent environment variable \"%s\"" name)))
+ (write-string value port)))
+ (loop end-pos)))))))))))))
+
+#| Tests for el:substitute-in-file-name.
+
+ (el:substitute-in-file-name "/foo/bar/baz") => "/foo/bar/baz"
+ (el:substitute-in-file-name "$$") => "$"
+ (el:substitute-in-file-name "/foo/ba$$r/baz") => "/foo/ba$r/baz"
+ (el:substitute-in-file-name "/foo/bar/baz$$") => "/foo/bar/baz$"
+ (el:substitute-in-file-name "$$/foo/bar/baz") => "$/foo/bar/baz"
+
+ (set-environment-variable! "V_A_R" "/test")
+
+ (el:substitute-in-file-name "$V_A_R") => "/test"
+ (el:substitute-in-file-name "/foo/$V_A_R-baz") => "/test-baz"
+ (el:substitute-in-file-name "$BOGUS/foo//bar$V_A_R") => "/bar/test"
+ (el:substitute-in-file-name "$V_A_R/bar/baz") => "/test/bar/baz"
+
+ (set-environment-variable! "V-A-R" "~guest/test")
+
+ (el:substitute-in-file-name "${V-A-R}") =>
+ "~guest/test"
+ (el:substitute-in-file-name "/foo/${V-A-R}-baz") =>
+ "~guest/test-baz"
+ (el:substitute-in-file-name "$BOGUS/foo//bar${V-A-R}") =>
+ "/bar~guest/test"
+ (el:substitute-in-file-name "${V-A-R}/bar/baz") =>
+ "~guest/test/bar/baz"
+
+ (el:substitute-in-file-name "$") =>
+ Error: Bad format environment-variable substitution.
+ (el:substitute-in-file-name "${V-A-R") =>
+ Error: Missing "}" in environment-variable substitution.
+ (el:substitute-in-file-name "${yowza!}") =>
+ Error: Substituting nonexistent environment variable "yowza!".
+|#
+
+(define file-error-types
+ (list condition-type:system-call-error
+ condition-type:file-operation-error))
+
+(define (report-file-error string data condition)
+ (let ((msg (cond ((eq? (condition/type condition)
+ condition-type:system-call-error)
+ (string-replace
+ (symbol->string (access-condition condition 'ERROR-TYPE))
+ #\- #\Space))
+ ((eq? (condition/type condition)
+ condition-type:file-operation-error)
+ (access-condition condition 'REASON))
+ (else (error "unexpected type of condition" condition)))))
+ (error:%signal Qfile-error (cons string (cons msg data)))))
+
+(define (barf-or-query-if-file-exists absname querystring interactive?)
+ (if (file-exists? absname)
+ (begin
+ (if (not interactive?)
+ (error:%signal Qfile-already-exists
+ (list "File already exists" absname)))
+ (if (not (prompt-for-yes-or-no?
+ (el:format "File %s already exists; %s anyway? "
+ absname querystring)))
+ (error:%signal Qfile-already-exists
+ (list "File already exists" absname))))))
+
+(DEFUN (el:copy-file filename newname
+ #!optional ok-if-already-exists keep-date)
+ "Copy FILE to NEWNAME. Both args strings.
+Signals a file-already-exists error if NEWNAME already exists,
+unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
+A number as third arg means request confirmation if NEWNAME already exists.
+This is what happens in interactive use with M-x.
+Fourth arg non-nil means give the new file the same last-modified time
+that the old one has. (This works on only some systems.)"
+ (interactive "fCopy file: \nFCopy %s to file: \np")
+ (let ((filename (expand-file-name (CHECK-STRING filename)))
+ (newname (expand-file-name (CHECK-STRING newname))))
+ (if (or (either-default? ok-if-already-exists)
+ (number? ok-if-already-exists))
+ (barf-or-query-if-file-exists newname "copy to it"
+ (number? ok-if-already-exists)))
+ #| errno is... gone?
+ (bind-condition-handler
+ (list condition-type:file-operation-error)
+ (lambda (condition)
+ (let ((pathname (access-condition condition 'FILENAME))
+ (verb (access-condition condition 'VERB))
+ (reason (access-condition ...)))
+ (cond ((and (string=? verb "open")
+ (string=? (->namestring pathname) filename))
+ (error:%signal
+ Qfile-error (list "Opening input file" reason filename)))
+ ((and (string=? verb "open")
+ (string=? (->namestring pathname) newname))
+ (error:%signal
+ Qfile-error (list "Opening output file" reason newname)))
+ (else
+ (error:%signal Qfile-error "I/O error" reason newname)))))
+ (lambda ()
+ (copy-file filename newname)))|#
+ (copy-file filename newname)
+ (if (not (or (either-default? keep-date) (null? keep-date)))
+ (let ((fatts (file-attributes-indirect filename)))
+ ((ucode-primitive set-file-times! 3)
+ newname
+ (file-attributes/access-time fatts)
+ (file-attributes/modification-time fatts))))
+ (set-file-modes! newname (file-modes filename)))
+ '())
+
+(DEFUN (el:delete-file filename)
+ "Delete specified file. One argument, a file name string.
+If file has multiple names, it continues to exist with the other names."
+ (interactive "fDelete file: ")
+ (let ((filename (expand-file-name (CHECK-STRING filename))))
+ (bind-condition-handler
+ file-error-types
+ (lambda (condition)
+ (report-file-error "Removing old name" (list filename) condition))
+ (lambda ()
+ (delete-file filename))))
+ '())
+
+(DEFUN (el:rename-file filename newname #!optional ok-if-already-exists)
+ "Rename FILE as NEWNAME. Both args strings.
+If file has names other than FILE, it continues to have those names.
+Signals a file-already-exists error if NEWNAME already exists
+unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
+A number as third arg means request confirmation if NEWNAME already exists.
+This is what happens in interactive use with M-x."
+ (interactive "fRename file: \nFRename %s to file: \np")
+ (let ((filename (expand-file-name (CHECK-STRING filename)))
+ (newname (expand-file-name (CHECK-STRING newname))))
+ (if (or (either-default? ok-if-already-exists)
+ (number? ok-if-already-exists))
+ (barf-or-query-if-file-exists newname "rename to it"
+ (number? ok-if-already-exists)))
+ (call-with-current-continuation
+ (lambda (continuation)
+ (bind-condition-handler
+ (list condition-type:system-call-error)
+ (lambda (condition)
+ (let ((error-type (access-condition condition 'ERROR-TYPE)))
+ (if (eq? error-type 'IMPROPER-LINK)
+ (begin
+ (el:copy-file filename newname
+ (if (default-object? ok-if-already-exists)
+ '()
+ ok-if-already-exists)
+ Qt)
+ (el:delete-file filename)
+ (continuation unspecific))
+ (report-file-error "Renaming"
+ (list filename newname)
+ condition))))
+ (lambda ()
+ (rename-file filename newname))))))
+ '())
+
+(DEFUN (el:add-name-to-file filename newname #!optional ok-if-already-exists)
+ "Give FILE additional name NEWNAME. Both args strings.
+Signals a file-already-exists error if NEWNAME already exists
+unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
+A number as third arg means request confirmation if NEWNAME already exists.
+This is what happens in interactive use with M-x."
+ (interactive "fAdd name to file: \nFName to add to %s: \np")
+ (let ((filename (expand-file-name (CHECK-STRING filename)))
+ (newname (expand-file-name (CHECK-STRING newname))))
+ (if (or (either-default? ok-if-already-exists)
+ (number? ok-if-already-exists))
+ (barf-or-query-if-file-exists newname "make it a new name"
+ (number? ok-if-already-exists)))
+ (bind-condition-handler
+ file-error-types
+ (lambda (condition)
+ (report-file-error "Adding new name"
+ (list filename newname)
+ condition))
+ (lambda ()
+ (if (file-exists? newname) (delete-file newname))
+ ((ucode-primitive file-link-hard 2) filename newname))))
+ '())
+
+(DEFUN (el:make-symbol-link filename newname #!optional ok-if-already-exists)
+ "Make a symbolic link to TARGET, named LINKNAME. Both args strings.
+There is no completion for LINKNAME, because it is read simply as a string;
+this is to enable you to make a link to a relative file name.
+
+Signals a file-already-exists error if LINKNAME already exists
+unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
+A number as third arg means request confirmation if LINKNAME already exists.
+This happens for interactive use with M-x."
+ (interactive "sMake symbolic link to file:
+FMake symbolic link to file %s:
+p")
+ (let ((filename (expand-file-name (CHECK-STRING filename)))
+ (newname (expand-file-name (CHECK-STRING newname))))
+ (if (or (either-default? ok-if-already-exists)
+ (number? ok-if-already-exists))
+ (barf-or-query-if-file-exists newname "make it a link"
+ (number? ok-if-already-exists)))
+ (bind-condition-handler
+ file-error-types
+ (lambda (condition)
+ (report-file-error "Making symbolic link"
+ (list filename newname)
+ condition))
+ (lambda ()
+ (if (file-exists? newname) (delete-file newname))
+ ((ucode-primitive file-link-soft 2) filename newname))))
+ '())
+
+#|(DEFUN (el:define-logical-name varname string)
+ "Define the job-wide logical name NAME to have the value STRING.
+If STRING is nil or a null string, the logical name NAME is deleted."
+ (interactive "sDefine logical name: \nsDefine logical name %s as: ")
+ )|#
+
+#|(DEFUN (el:sysnetunam path login)
+ "Open a network connection to PATH using LOGIN as the login string.")|#
+
+(DEFUN (el:file-name-absolute-p filename)
+ "Return t if file FILENAME specifies an absolute path name."
+ (let ((first-char (string-ref (CHECK-STRING filename) 0)))
+ (if (or (char=? #\/ first-char)
+ (char=? #\~ first-char))
+ Qt '())))
+
+(DEFUN (el:file-exists-p filename)
+ "Return t if file FILENAME exists. (This does not mean you can read it.)
+See also file-readable-p and file-attributes."
+ (let ((filename (expand-file-name (CHECK-STRING filename))))
+ (if (file-exists? filename)
+ Qt '())))
+
+(DEFUN (el:file-readable-p filename)
+ "Return t if file FILENAME exists and you can read it.
+See also file-exists-p and file-attributes."
+ (let ((filename (expand-file-name (CHECK-STRING filename))))
+ (if (file-access filename 4)
+ Qt '())))
+
+(DEFUN (el:file-symlink-p filename)
+ "If file FILENAME is the name of a symbolic link
+returns the name of the file to which it is linked.
+Otherwise returns NIL."
+ (let ((filename (expand-file-name (CHECK-STRING filename))))
+ (or (file-symbolic-link? filename)
+ '())))
+
+(DEFUN (el:file-writable-p filename)
+ "Return t if file FILENAME can be written or created by you."
+ (let ((filename (expand-file-name (CHECK-STRING filename))))
+ (if (file-access filename 0)
+ (if (file-access filename 2)
+ Qt '())
+ (if (file-access (directory-pathname-as-file filename) 2)
+ Qt '()))))
+
+(DEFUN (el:file-directory-p filename)
+ "Return t if file FILENAME is the name of a directory as a file.
+A directory name spec may be given instead; then the value is t
+if the directory so specified exists and really is a directory."
+ (let ((filename (expand-file-name (CHECK-STRING filename))))
+ (if (file-directory? filename)
+ Qt '())))
+
+(DEFUN (el:file-modes filename)
+ "Return mode bits of FILE, as an integer."
+ (let ((filename (expand-file-name (CHECK-STRING filename))))
+ (file-modes filename)))
+
+(DEFUN (el:set-file-modes filename mode)
+ "Set mode bits of FILE to MODE (an integer).
+Only the 12 low bits of MODE are used."
+ (let ((filename (expand-file-name (CHECK-STRING filename)))
+ (mode (CHECK-NUMBER mode)))
+ (bind-condition-handler
+ file-error-types
+ (lambda (condition)
+ (report-file-error "Doing chmod" (list filename)
+ condition))
+ (lambda ()
+ (set-file-modes! filename (modulo mode #o10000)))))
+ '())
+
+(DEFUN (el:file-newer-than-file-p file1 file2)
+ "Return t if file FILE1 is newer than file FILE2.
+If FILE1 does not exist, the answer is nil;
+otherwise, if FILE2 does not exist, the answer is t."
+ (let ((time1 (file-modification-time-indirect
+ (expand-file-name (CHECK-STRING file1))))
+ (time2 (file-modification-time-indirect
+ (expand-file-name (CHECK-STRING file2)))))
+ (cond ((null? time1) '())
+ ((null? time2) Qt)
+ ((> time1 time2) Qt)
+ (else '()))))
+
+(DEFUN (el:insert-file-contents filename #!optional visit)
+ "Insert contents of file FILENAME after point.
+Returns list of absolute pathname and length of data inserted.
+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)))))))
+
+(DEFUN (el:write-region start end filename #!optional append visit)
+ "Write current region into specified file.
+When called from a program, takes three arguments:
+START, END and FILENAME. START and END are buffer positions.
+Optional fourth argument APPEND if non-nil means
+ append to existing file contents (if any).
+Optional fifth argument VISIT if t means
+ set last-save-file-modtime of buffer to this file's modtime
+ and mark buffer not modified.
+If VISIT is neither t nor nil, it means do not print
+ the \"Wrote file\" message."
+ (interactive "r\nFWrite region to file: ")
+ (let ((buffer (%current-buffer)))
+ (let ((region (if (null? start)
+ (buffer-region buffer)
+ (CHECK-REGION start end buffer)))
+ (filename (expand-file-name (CHECK-STRING filename))))
+ (let ((truename
+ (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))
+ truename))))
+
+(DEFUN (el:verify-visited-file-modtime buf)
+ "Return t if last mod time of BUF's visited file matches what BUF records.
+This means that the file has not been changed since it was visited or saved."
+ (let ((buffer (CHECK-BUFFER buf)))
+ (if (verify-visited-file-modification-time? buffer)
+ Qt '())))
+
+(DEFUN (el:clear-visited-file-modtime)
+ "Clear out records of last mod time of visited file.
+Next attempt to save will certainly not complain of a discrepancy."
+ (clear-visited-file-modification-time! (%current-buffer))
+ '())
+
+(DEFUN (el:do-auto-save #!optional nomsg)
+ "Auto-save all buffers that need it.
+This is all buffers that have auto-saving enabled
+and are changed since last auto-saved.
+Auto-saving writes the buffer into a file
+so that your editing is not lost if the system crashes.
+This file is not the file you visited; that changes only when you save.
+
+Non-nil argument means do not print any message if successful.
+
+NOTE: The nomsg argument is not supported by Edwin."
+ (interactive "")
+ nomsg
+ (do-auto-save)
+ '())
+
+(DEFUN (el:set-buffer-auto-saved)
+ "Mark current buffer as auto-saved with its current text.
+No auto-save file will be written until the buffer changes again."
+ (let ((buffer (%current-buffer)))
+ (let ((modified? (buffer-modified? buffer)))
+ ;; I don't understand why this causes a buffer to be flagged as
+ ;; modified.
+ (set-buffer-auto-saved! buffer)
+ (if (not modified?)
+ (buffer-not-modified! buffer))))
+ '())
+
+(DEFUN (el:recent-auto-save-p)
+ "Return t if buffer has been auto-saved since last read in or saved."
+ (if (buffer-auto-saved? (%current-buffer))
+ Qt '()))
+
+#|(DEFUN (el:read-file-name-internal string dir action)
+ "Internal subroutine for read-file-name. Do not call this.")|#
+
+(DEFUN (el:read-file-name prompt #!optional dir default mustmatch)
+ "Read file name, prompting with PROMPT and completing in directory DIR.
+Value is not expanded! You must call expand-file-name yourself.
+Default name to DEFAULT if user enters a null string.
+Fourth arg MUSTMATCH non-nil means require existing file's name.
+ Non-nil and non-t means also require confirmation after completion.
+DIR defaults to current buffer's directory default."
+ (let ((prompt (CHECK-STRING prompt))
+ (directory (if (either-default? dir)
+ (->namestring (buffer-default-directory
+ (%current-buffer)))
+ (CHECK-STRING dir)))
+ (default (if (either-default? default)
+ (->namestring (buffer-pathname (%current-buffer)))
+ (CHECK-STRING default)))
+ (existing? (not (either-default? mustmatch)))
+ (confirm? (and (not (either-default? mustmatch))
+ (not (eq? Qt mustmatch)))))
+ (let ((insdef (if (%symbol-value Qinsert-default-directory)
+ directory
+ "")))
+ (%specbind
+ (list Qcompletion-ignore-case) (list Qt)
+ (lambda ()
+ (let ((val (->namestring
+ (prompt-for-pathname* prompt insdef file-non-directory?
+ (cond (confirm? 'confirm)
+ (existing? true)
+ (else false))))))
+ (cond ((null? val)
+ (error:%signal Qerror (list "No file name specified")))
+ ((string=? val insdef)
+ default)
+ (else (el:substitute-in-file-name val)))))))))
+\f
+;;;; Utilities
+
+(define (string-components string delimiter)
+ (substring-components string 0 (string-length string) delimiter))
+
+(define (substring-components string start end delimiter)
+ (let loop ((start start))
+ (let ((index (substring-find-next-char string start end delimiter)))
+ (if index
+ (cons (substring string start index) (loop (+ 1 index)))
+ (list (substring string start end))))))
+
+(define (list->commaized-string list comma)
+ (apply string-append
+ (let loop ((input list)
+ (output ()))
+ (if (pair? input)
+ (loop (cdr input)
+ (cons comma (cons (car input) output)))
+ (reverse! output)))))
+
+(define (components-string list delimiter)
+ (apply string-append
+ (if (pair? list)
+ (cons (car list)
+ (let loop ((input (cdr list))
+ (output ()))
+ (if (pair? input)
+ (loop (cdr input)
+ (cons (car input) (cons delimiter output)))
+ (reverse! output))))
+ ())))
+
+(define (write-substring string start #!optional end port)
+ (let ((port (if (default-object? port) (current-output-port) port))
+ (end (if (default-object? end) (string-length string) end)))
+ (output-port/write-substring port string start end)))
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Random utility Lisp functions. |#
+
+(declare (usual-integrations))
+\f
+(DEFVAR Qfeatures
+ '()
+ "A list of symbols which are the features of the executing emacs.
+Used by featurep and require, and altered by provide.")
+
+(DEFUN (el:identity arg)
+ "Return the argument unchanged."
+ arg)
+
+(define elisp-random-state
+ (make-random-state (+ (real-time-clock) (* (process-time-clock) 10000))))
+
+(DEFUN (el:random #!optional arg)
+ "Return a pseudo-random number.
+On most systems all integers representable in Lisp are equally likely.
+ This is 24 bits' worth.
+On some systems, absolute value of result never exceeds 2 to the 14.
+If optional argument is supplied as t,
+ the random number seed is set based on the current time and pid.
+
+NOTE: The random number seed is set based on the current real and
+process times only."
+ (if (and (not (default-object? arg))
+ (eq? arg Qt))
+ (set! elisp-random-state
+ (make-random-state (+ (real-time-clock)
+ (* (process-time-clock) 10000)))))
+ (- (random (expt 2 24)) (expt 2 23)))
+
+;;; Random data-structure functions
+
+(DEFUN (el:length obj)
+ "Return the length of vector, list or string SEQUENCE."
+ (cond ((string? obj) (string-length obj))
+ ((vector? obj) (vector-length obj))
+ ((pair? obj) (length obj))
+ ((null? obj) 0)
+ (else (el:length (wrong-type-argument Qsequencep obj)))))
+
+(DEFUN (el:string-equal s1 s2)
+ "T if two strings have identical contents.
+Symbols are also allowed; their print names are used instead."
+ (let ((s1 (cond ((%symbol? s1) (%symbol-name s1))
+ (else (CHECK-STRING s1))))
+ (s2 (cond ((%symbol? s2) (%symbol-name s2))
+ (else (CHECK-STRING s2)))))
+ (if (string=? s1 s2) Qt '())))
+
+(DEFUN (el:string-lessp s1 s2)
+ "T if first arg string is less than second in lexicographic order.
+Symbols are also allowed; their print names are used instead."
+ (let ((s1 (cond ((%symbol? s1) (%symbol-name s1))
+ (else (CHECK-STRING s1))))
+ (s2 (cond ((%symbol? s2) (%symbol-name s2))
+ (else (CHECK-STRING s2)))))
+ (if (string<? s1 s2) Qt '())))
+
+(DEFUN (el:append . args)
+ "Concatenate arguments and make the result a list.
+The result is a list whose elements are the elements of all the arguments.
+Each argument may be a list, vector or string."
+ (let loop ((args args)(result '()))
+ (if (pair? args)
+ (let ((this (car args))
+ (rest (cdr args)))
+ (cond ((null? this)
+ (loop rest result))
+ ((pair? this)
+ (if (null? rest)
+ (append! (reverse! result) this)
+ (loop rest (append! (el:nreverse this) result))))
+ ((string? this)
+ (for-char this
+ (lambda (char)
+ (set! result (cons (char->ascii char) result))))
+ (loop rest result))
+ ((vector? this)
+ (for-elt this (lambda (element)
+ (set! result (cons element result))))
+ (loop rest result))
+ ((number? this)
+ (loop (cons (el:int-to-string this) rest) result))
+ (else (loop (cons (wrong-type-argument Qsequencep this) rest)
+ result))))
+ (reverse! result))))
+
+(DEFUN (el:concat . args)
+ "Concatenate arguments and make the result a string.
+The result is a string whose elements are the elements of all the arguments.
+Each argument may be a string, a list of numbers, or a vector of numbers."
+ (let ((write-char-with-check
+ (lambda (elt)
+ (write-char (ascii->char (modulo (CHECK-NUMBER elt) 255))))))
+ (with-output-to-string
+ (lambda ()
+ (let loop ((args args))
+ (if (pair? args)
+ (let ((this (car args)))
+ (cond ((null? this)
+ (loop (cdr args)))
+ ((pair? this)
+ (for-each this write-char-with-check)
+ (loop (cdr args)))
+ ((string? this)
+ (for-char this write-char)
+ (loop (cdr args)))
+ ((vector? this)
+ (for-elt this write-char-with-check)
+ (loop (cdr args)))
+ ((number? this)
+ (write-string (el:int-to-string this)))
+ (else
+ (loop (cons (wrong-type-argument Qsequencep this)
+ (cdr args))))))
+ unspecific))))))
+
+(DEFUN (el:vconcat . args)
+ "Concatenate arguments and make the result a vector.
+The result is a vector whose elements are the elements of all the arguments.
+Each argument may be a list, vector or string."
+ (let loop ((args args)(result '()))
+ (if (pair? args)
+ (let ((this (car args))
+ (rest (cdr args)))
+ (cond ((null? this)
+ (loop rest result))
+ ((pair? this)
+ (loop rest (append! (el:nreverse this) result)))
+ ((string? this)
+ (for-char this
+ (lambda (char)
+ (set! result (cons (char->ascii char) result))))
+ (loop rest result))
+ ((vector? this)
+ (for-elt this (lambda (element)
+ (set! result (cons element result))))
+ (loop rest result))
+ ((number? this)
+ (loop (cons (el:int-to-string this) rest) result))
+ (else (loop (cons (wrong-type-argument Qsequencep this) rest)
+ result))))
+ (list->vector (reverse! result)))))
+
+(DEFUN (el:copy-sequence arg)
+ "Return a copy of a list, vector or string."
+ (cond ((null? arg) arg)
+ ((pair? arg) (list-copy arg))
+ ((string? arg) (string-copy arg))
+ ((vector? arg) (vector-copy arg))
+ (else
+ (el:copy-sequence (wrong-type-argument Qsequencep arg)))))
+
+(DEFUN (el:copy-alist alist)
+ "Return a copy of ALIST.
+This is a new alist which represents the same mapping
+from objects to objects, but does not share the alist structure with ALIST.
+The objects mapped (cars and cdrs of elements of the alist)
+are shared, however."
+ (if (comtab? alist)
+ (el:copy-keymap alist)
+ (let ((alist (CHECK-LIST alist)))
+ (alist-copy alist))))
+
+(DEFUN (el:substring string from #!optional to)
+ "Return a substring of STRING, starting at index FROM and ending before TO.
+TO may be nil or omitted; then the substring runs to the end of STRING.
+If FROM or TO is negative, it counts from the end."
+ (let* ((string (CHECK-STRING string))
+ (length (string-length string))
+ (from (let ((from (CHECK-NUMBER from)))
+ (if (< from 0) (+ length from) from)))
+ (to (if (either-default? to)
+ length
+ (let ((to (CHECK-NUMBER to)))
+ (if (< to 0) (+ length to) to)))))
+ (if (not (and (<= 0 from) (<= from to) (<= to length)))
+ (apply el:substring
+ (error:%signal Qargs-out-of-range (list string from to)))
+ (substring string from to))))
+
+(DEFUN (el:nthcdr n list)
+ "Takes cdr N times on LIST, returns the result."
+ (let ((n (CHECK-NUMBER n)))
+ (cond ((<= n 0) list)
+ ((< (length list) n) '())
+ (else (list-tail list n)))))
+
+(DEFUN (el:nth n list)
+ "Returns the Nth element of LIST.
+N counts from zero. If LIST is not that long, nil is returned."
+ (let ((n (max (CHECK-NUMBER n) 0))
+ (list (CHECK-LIST list)))
+ (cond ((< (length list) n) '())
+ (else (list-ref list n)))))
+
+(DEFUN (el:elt seq n)
+ "Returns element of SEQUENCE at index N."
+ (cond ((null? seq) '())
+ ((pair? seq)
+ (el:nth n seq))
+ ((or (string? seq) (vector? seq))
+ (el:aref seq n))
+ (else (el:elt (wrong-type-argument Qsequencep seq) n))))
+
+(DEFUN (el:memq elt list)
+ "Returns non-nil if ELT is an element of LIST. Comparison done with EQ.
+The value is actually the tail of LIST whose car is ELT."
+ (let loop ((tail list))
+ (cond ((null? tail) '())
+ ((el:eq (el:car tail) elt) tail)
+ (else (loop (el:cdr tail))))))
+
+(DEFUN (el:assq key list)
+ "Returns non-nil if ELT is the car of an element of LIST. Comparison done with eq.
+The value is actually the element of LIST whose car is ELT."
+ (let loop ((tail list))
+ (if (null? tail)
+ '()
+ (let ((elt (el:car tail)))
+ (if (and (pair? elt)
+ (el:eq (car elt) key))
+ elt
+ (loop (cdr tail)))))))
+
+(DEFUN (el:assoc key list)
+ "Returns non-nil if ELT is the car of an element of LIST. Comparison done with equal.
+The value is actually the element of LIST whose car is ELT."
+ (let loop ((tail list))
+ (if (null? tail)
+ '()
+ (let ((elt (el:car tail)))
+ (if (and (pair? elt)
+ (el:equal (car elt) key))
+ elt
+ (loop (cdr tail)))))))
+
+(DEFUN (el:rassq key list)
+ "Returns non-nil if ELT is the cdr of an element of LIST. Comparison done with EQ.
+The value is actually the element of LIST whose cdr is ELT."
+ (let loop ((tail list))
+ (if (null? tail)
+ '()
+ (let ((elt (el:car tail)))
+ (if (and (pair? elt)
+ (el:eq (cdr elt) key))
+ elt
+ (loop (cdr tail)))))))
+
+(DEFUN (el:delq elt list)
+ "Deletes by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned.
+If the first member of LIST is ELT, there is no way to remove it by side effect;
+therefore, write (setq foo (delq element foo)) to be sure of changing foo."
+ (let loop ((tail list)
+ (prev '()))
+ (cond ((null? tail) list)
+ ((el:eq (el:car tail) elt)
+ (let ((cdr (cdr tail)))
+ (if (null? prev)
+ (set! list cdr)
+ (set-cdr! prev cdr))
+ (loop cdr prev)))
+ (else (loop (cdr tail) tail)))))
+
+(DEFUN (el:nreverse list)
+ "Reverses LIST by modifying cdr pointers. Returns the beginning of the reversed list."
+ (let loop ((tail list)
+ (prev '()))
+ (if (null? tail)
+ prev
+ (let ((next (el:cdr tail)))
+ (set-cdr! tail prev)
+ (loop next tail)))))
+
+(DEFUN (el:reverse list)
+ "Reverses LIST, copying. Returns the beginning of the reversed list.
+See also the function nreverse, which is used more often."
+ (let loop ((tail list)
+ (result '()))
+ (if (null? tail)
+ result
+ (loop (el:cdr tail) (cons (el:car tail) result)))))
+
+(DEFUN (el:sort list pred)
+ "Sort LIST, stably, comparing elements using PREDICATE.
+Returns the sorted list. LIST is modified by side effects.
+PREDICATE is called with two elements of LIST, and should return T
+if the first element is \"less\" than the second."
+ ;; Check that LIST is a valid list. (Emacs signals wrong-type-argument if a
+ ;; tail of list isn't a list.) (Scheme just drops a bogus tail.) (Just
+ ;; for laughs, accept replacement [sub]list value returned by
+ ;; wrong-type-argument.)
+ (let loop ((tail list)
+ (prev '()))
+ (cond ((null? tail))
+ ((pair? tail)
+ (loop (cdr tail) tail))
+ (else
+ (if (null? prev)
+ (begin
+ (set! list (wrong-type-argument Qlistp tail))
+ (loop list '()))
+ (begin
+ (set-cdr! prev (wrong-type-argument Qlistp tail))
+ (loop (cdr (cdr prev)) (cdr prev)))))))
+ (sort list (lambda (elt1 elt2)
+ (el:funcall pred elt1 elt2))))
+
+(DEFUN (el:get sym prop)
+ "Return the value of SYMBOL's PROPNAME property.
+This is the last VALUE stored with (put SYMBOL PROPNAME VALUE)."
+ (%get (CHECK-SYMBOL sym) prop))
+
+(DEFUN (el:put sym prop val)
+ "Store into SYMBOL's PROPERTY the VALUE.
+It can be retrieved with (get SYMBOL PROPERTY)."
+ (%put! (CHECK-SYMBOL sym) prop val)
+ val)
+
+(DEFUN (el:equal o1 o2)
+ "T if two Lisp objects have similar structure and contents.
+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))))
+
+(DEFUN (el:fillarray array item)
+ "Store each element of ARRAY with ITEM. ARRAY is a vector or string."
+ (cond ((vector? array)
+ (vector-fill! array item))
+ ((string? array)
+ (string-fill! array (ascii->char (modulo (CHECK-NUMBER item) 255))))
+ (else
+ (el:fillarray (wrong-type-argument Qarrayp array) item))))
+
+(DEFUN (el:nconc . args)
+ "Concatenate any number of lists by altering them.
+Only the last argument is not altered, and need not be a list."
+ (append-map! (lambda (arg) (CHECK-LIST arg)) args))
+
+(define (mapcar1 seq receiver)
+ (cond ((vector? seq)
+ (for-elt seq receiver))
+ ((string? seq)
+ (for-char seq receiver))
+ ((pair? seq)
+ (for-each seq receiver))
+ (else (error:wrong-type-datum seq "a list"))))
+
+(DEFUN (el:mapconcat fn seq #!optional sep)
+ "Apply FN to each element of SEQ, and concat the results as strings.
+In between each pair of results, stick in SEP.
+Thus, \" \" as SEP results in spaces between the values return by FN."
+ (let ((sep (if (either-default? sep) "" sep))
+ (need-sep? false))
+ (with-output-to-string
+ (lambda ()
+ (mapcar1 seq (lambda (elt)
+ (if need-sep? (display sep) (set! need-sep? #!true))
+ (display (el:funcall fn elt))))))))
+
+(DEFUN (el:mapcar fn list)
+ "Apply FUNCTION to each element of LIST, and make a list of the results.
+The result is a list just as long as LIST."
+ (cond ((null? list) '())
+ ((pair? list) (%mapcar-list fn list))
+ ((and (event-distributor? list)
+ (or (eq? fn Qfuncall)
+ (eq? fn el:funcall)))
+ (event-distributor/invoke! list))
+ (else (wrong-type-argument Qlistp list))))
+
+(define (%mapcar-list fn list)
+ (let loop ((tail list)(res '()))
+ (cond ((null? tail) (el:nreverse res))
+ ((pair? tail)
+ (loop (cdr tail) (cons (el:funcall fn (car tail)) res)))
+ (else (wrong-type-argument Qlistp tail)))))
+
+(DEFUN (el:y-or-n-p prompt)
+ "Ask user a \"y or n\" question. Return t if answer is \"y\".
+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
+ (lambda ()
+ (let loop ((lost? false))
+ (let ((char (keyboard-read)))
+ (cond ((and (char? char)
+ (or (char-ci=? char #\y)
+ (char-ci=? char #\space)))
+ (set-typein-string! "y" true)
+ Qt)
+ ((and (char? char)
+ (or (char-ci=? char #\n)
+ (char-ci=? char #\rubout)))
+ (set-typein-string! "n" true)
+ '())
+ (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)))))))|#)
+
+(DEFUN (el:yes-or-no-p prompt)
+ "Ask user a yes or no question. Return t if answer is yes.
+The user must confirm the answer with a newline, and can rub it out if not confirmed."
+ ;; This is a copy of `prompt-for-yes-or-no?' that appends "(yes or no) "
+ ;; rather than " (yes or no)? " to `prompt'.
+ (if (string-ci=?
+ "Yes"
+ (prompt-for-typein
+ (string-append prompt "(yes or no) ") true
+ (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)))))))|#)
+
+#|(DEFUN (el:load-average)
+ "Return the current 1 minute, 5 minute and 15 minute load averages
+in a list (all floating point load average values are multiplied by 100
+and then turned into integers).")|#
+
+(DEFUN (el:featurep feature)
+ "Returns t if FEATURE is present in this Emacs.
+Use this to conditionalize execution of lisp code based on the presence or
+absence of emacs or environment extensions.
+Use provide to declare that a feature is available.
+This function looks at the value of the variable features."
+ (let* ((feature (CHECK-SYMBOL feature))
+ (entry (el:memq feature (%symbol-value Qfeatures))))
+ (if (null? entry) '() Qt)))
+
+(DEFUN (el:provide feature)
+ "Announce that FEATURE is a feature of the current Emacs."
+ (let ((feature (CHECK-SYMBOL feature)))
+ (if (not (null? autoload-queue))
+ (set! autoload-queue
+ (cons (list (%symbol-value Qfeatures)) autoload-queue)))
+ (let* ((features (%symbol-value Qfeatures))
+ (entry (el:memq feature features)))
+ (if (null? entry)
+ (%set-symbol-value! Qfeatures (cons feature features))))
+ feature))
+
+(DEFUN (el:require feature #!optional filename)
+ "If FEATURE is not present in Emacs (ie (featurep FEATURE) is false),
+load FILENAME. FILENAME is optional and defaults to FEATURE."
+ (let ((feature (CHECK-SYMBOL feature)))
+ (if (null? (el:memq feature (%symbol-value Qfeatures)))
+ (begin
+ (protect-with-autoload-queue
+ (lambda ()
+ (el:load (if (either-default? filename)
+ (%symbol-name feature)
+ filename)
+ '() Qt '())))
+ (if (null? (el:memq feature (%symbol-value Qfeatures)))
+ (error:%signal
+ Qerror (list (el:format "Required feature %s was not provided"
+ feature))))))
+ feature))
+
+(define (for-char string receiver)
+ (let ((length (string-length string)))
+ (let loop ((idx 0))
+ (if (< idx length)
+ (begin
+ (receiver (string-ref string idx))
+ (loop (1+ idx)))))))
+
+(define (for-elt vector receiver)
+ (let ((length (vector-length vector)))
+ (let loop ((index 0))
+ (if (< index length)
+ (begin
+ (receiver (vector-ref vector index))
+ (loop (1+ index)))))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Indentation functions. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:current-column)
+ "Return the horizontal position of point. Beginning of line is column 0.
+This is calculated by adding together the widths of all the displayed
+representations of the character between the start of the previous line
+and point. (eg control characters will have a width of 2 or 4, tabs
+will have a variable width)
+Ignores finite width of screen, which means that this function may return
+values greater than (screen-width).
+Whether the line is visible (if `selective-display' is t) has no effect."
+ (mark-column (buffer-point (%current-buffer))))
+
+(DEFUN (el:indent-to col #!optional minimum)
+ "Indent from point with tabs and spaces until COLUMN is reached.
+Always do at least MIN spaces even if that goes past COLUMN;
+by default, MIN is zero."
+ (interactive "NIndent to column: ")
+ (let ((col (CHECK-NUMBER col))
+ (min (if (either-default? minimum)
+ 0
+ (CHECK-NUMBER minimum)))
+ (point (buffer-point (%current-buffer))))
+ (let* ((current-column (mark-column point))
+ (desired-column (if (< (+ current-column min) col)
+ col
+ (+ current-column min))))
+ (if (not (= current-column desired-column))
+ (%fixup-window-point-movement
+ (%current-buffer) point
+ (lambda () (insert-horizontal-space desired-column point))))
+ desired-column)))
+
+(DEFUN (el:current-indentation)
+ "Return the indentation of the current line.
+This is the horizontal position of the character
+following any initial whitespace."
+ (current-indentation (buffer-point (%current-buffer))))
+
+(DEFUN (el:move-to-column column)
+ "Move point to column COLUMN in the current line.
+COLUMN is calculated by adding together the widths of all the displayed
+representations of the character between the start of the previous line
+and point. (eg control characters will have a width of 2 or 4, tabs
+will have a variable width)
+Ignores finite width of screen, which means that this function may be
+passed values greater than (screen-width)"
+ (let ((column (CHECK-NUMBER column))
+ (buffer (%current-buffer)))
+ (set-buffer-point! buffer (move-to-column (buffer-point buffer) column))
+ column))
+
+#|(DEFUN (el:vertical-motion lines)
+ "Move to start of screen line LINES lines down.
+If LINES is negative, this is moving up.
+Sets point to position found; this may be start of line
+ or just the start of a continuation line.
+Returns number of lines moved; may be closer to zero than LINES
+ if beginning or end of buffer was reached."
+ ;;
+ ;; This is a weird one. GNU Emacs uses the width and hscroll of the
+ ;; selected-window regardless of whether the buffer is in it or
+ ;; another window or none at all! The buffer position is changed,
+ ;; but this doesn't affect a window position unless it is the buffer
+ ;; in the selected window.
+ ;;
+ ;; Edwin doesn't provide any convenient procedures for doing this.
+ ;; `predict-index' takes a window and computes a new position in the
+ ;; window's buffer.
+ ;;
+ ;; So I'm punting for now.
+ ;;
+ ;; Frob buffer/window correspondence?
+ ;(with-selected-buffer (%current-buffer)
+ ; (lambda ()
+ ; (let ((window (current-window)))
+ ; (set-current-point!
+ ; (make-mark
+ ; (window-group window)
+ ; (predict-index window
+ ; (%window-current-start-index window)
+ ; (%window-current-start-y window)
+ ; 0
+ ; ...))))))
+ )|#
+
+(DEFVAR Qindent-tabs-mode
+ unassigned
+ "*Indentation can insert tabs if this is non-nil.
+Setting this variable automatically makes it local to the current buffer.
+
+NOTE: This variable can only be a boolean in Edwin."
+ (boolean-getter (ref-variable-object indent-tabs-mode))
+ (boolean-setter (ref-variable-object indent-tabs-mode)))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Manipulation of keymaps
+
+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
+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
+symbol, pair (lambda), or another comtab. This anonymous command will
+not work with Edwin's command history, which records the name of the
+command that was invoked. However, commands invoked via a keymap are
+not generally recorded in the command history, so the impact of this
+restriction may be minimal. Note that the type of datum handed to
+el:define-key is not checked. If it's wrong, an error will be signaled
+when the anonymous command is invoked. This is consistent with GNU Emacs'
+own define-key, which does no checking of the definition.
+
+An ELisp mode always uses the comtab of the Fundamental Edwin mode for its
+global-keymap. A second comtab will hold local key bindings. Edwin minor
+modes can still be enabled and their key bindings will take precedence over
+any local or global Emacs key bindings. Setting the local-map of an Emacs
+mode changes the second comtab, and defining local keys will mutate the
+second comtab. Edwin minor modes will not be affected. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:make-keymap)
+ "Construct and return a new keymap, a vector of length 128.
+All entries in it are nil, meaning \"command undefined\".
+
+NOTE: Edwin requires that this be a comtab."
+ (make-comtab))
+
+(DEFUN (el:make-sparse-keymap)
+ "Construct and return a new sparse-keymap list.
+Its car is 'keymap and its cdr is an alist of (CHAR . DEFINITION).
+Initially the alist is nil.
+
+NOTE: Edwin requires that this be a comtab."
+ (make-comtab))
+
+(DEFUN (el:keymapp object)
+ "Return t if ARG is a keymap.
+A keymap is a vector of length 128, or a list (keymap . ALIST),
+where alist elements look like (CHAR . DEFN).
+A symbol whose function definition is a keymap is itself a keymap."
+ (let loop ((object object))
+ (cond ((comtab? object) Qt)
+ ((and (%symbol? object)
+ (%symbol-fbound? object))
+ (loop (%symbol-function object)))
+ (else '()))))
+
+(DEFUN (el:copy-keymap keymap)
+ "Return a copy of the keymap KEYMAP.
+The copy starts out with the same definitions of KEYMAP,
+but changing either the copy or KEYMAP does not affect the other.
+Any key definitions that are subkeymaps are recursively copied.
+However, a key definition which is a symbol whose definition is a keymap
+is not copied."
+ (let ((comtab (CHECK-KEYMAP keymap)))
+ (comtab-tree-copy comtab)))
+
+(define (comtab-tree-copy comtab)
+ (let ((new (make-comtab))
+ (copy-datum
+ (lambda (datum)
+ (cond ((not datum) false)
+ ((command? datum) datum)
+ ((comtab? datum)
+ (comtab-tree-copy datum))
+ ((command&comtab? datum)
+ (cons (car datum) (comtab-tree-copy (cdr datum))))
+ ((comtab-alias? datum) datum)
+ (else (error:wrong-type-datum datum "valid comtab datum"))))))
+ (set-comtab-vector!
+ new
+ (let ((vector (comtab-vector comtab)))
+ (if (vector? vector)
+ (make-initialized-vector
+ (vector-length vector)
+ (lambda (index) (copy-datum (vector-ref vector index))))
+ vector)))
+ (set-comtab-alist!
+ new
+ (map (lambda (entry) (cons (car entry) (copy-datum (cdr entry))))
+ (comtab-alist comtab)))
+ new))
+\f
+;;; When loading essential runtime files like simple.el, we want the
+;;; simple Emacs Lisp functions, but not the global-map definitions.
+(define allow-elisp-define-key-overrides? true)
+
+(DEFUN (el:define-key keymap key def)
+ "Args KEYMAP, KEY, DEF. Define key sequence KEY, in KEYMAP, as DEF.
+KEYMAP is a keymap. KEY is a string meaning a sequence of keystrokes.
+DEF is anything that can be a key's definition:
+ nil (means key is undefined in this keymap),
+ a command (a Lisp function suitable for interactive calling)
+ a string (treated as a keyboard macro),
+ a keymap (to define a prefix key),
+ a list (KEYMAP . CHAR), meaning use definition of CHAR in map KEYMAP,
+ or a symbol. The symbol's function definition is used as the key's
+definition, and may be any of the above (including another symbol)."
+ (let ((comtab (CHECK-KEYMAP keymap))
+ (keys (emacs-keys->edwin-keys (CHECK-STRING key))))
+ (if (null? keys)
+ ;; GNU Emacs 18.58 doesn't signal if `key' is ""!
+ '()
+ (let ((value (%lookup-key comtab keys)))
+ (cond ((number? value)
+ (error:%signal
+ Qerror
+ (list "Key sequence %s uses invalid prefix characters" key)))
+ ((and (not (null? value))
+ (not (anonymous-elisp-command? value))
+ (not allow-elisp-define-key-overrides?))
+ ;; Punt!
+ )
+ (else
+ (%define-key comtab keys (->comtab-datum def)
+ 'EL:DEFINE-KEY))))))
+ def)
+
+(define (emacs-keys->edwin-keys string)
+ (let ((chars (string->list string)))
+ (if (and (pair? chars)
+ (char=? (car chars) #\Altmode)
+ (pair? (cdr chars)))
+ (cons (char-metafy (car (cdr chars))) (cddr chars))
+ chars)))
+
+(define elisp-comtab-binding-tag "??")
+
+(define (anonymous-elisp-command? obj)
+ (and (command? obj)
+ (eq? (command-description obj) elisp-comtab-binding-tag)))
+
+(define (->comtab-datum datum)
+ (cond ((null? datum)
+ false)
+ ((or (command? datum) (comtab? datum) (comtab-alias? datum))
+ datum)
+ ((and (%symbol? datum)
+ (%symbol-command datum)
+ ;; Try not to use commands that have been overridden and
+ ;; are no longer in the editor-commands table.
+ (eq? (%symbol-command datum)
+ (string-table-get editor-commands (%symbol-name datum))))
+ (%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)
+ command))))
+
+(define (%keymap-dispatch datum)
+ ;; Valid Emacs keymap data are: macros (strings), interactive lambda
+ ;; expressions, command symbols, prefix command symbols, and keymaps
+ ;; (comtabs).
+ ;; All but keymaps (comtabs) are turned into anonymous emacs lisp
+ ;; commands.
+ ;; Of course, Emacs Lisp allows anything to become a keymap datum,
+ ;; and signals errors when they can't be dispatched upon.
+ (let ((datum* (if (%symbol? datum)
+ (%function* datum)
+ datum)))
+ (cond ((string? datum*)
+ (keyboard-macro-execute datum*
+ (command-argument-numeric-value
+ (command-argument))))
+ ((or (%subr? datum*)
+ (and (pair? datum*)
+ (or (eq? (car datum*) Qlambda)
+ (eq? (car datum*) Qautoload))))
+ (%call-interactively (current-buffer) datum false))
+ (else (%keymap-dispatch (wrong-type-argument Qcommandp datum))))))
+
+(DEFUN (el:lookup-key keymap key)
+ "In keymap KEYMAP, look up key sequence KEY. Return the definition.
+nil means undefined. See doc of define-key for kinds of definitions.
+Number as value means KEY is \"too long\";
+that is, characters in it except for the last one
+fail to be a valid sequence of prefix characters in KEYMAP.
+The number is how many characters at the front of KEY
+it takes to reach a non-prefix command."
+ (let ((comtab (CHECK-KEYMAP keymap))
+ (keys (emacs-keys->edwin-keys (CHECK-STRING key))))
+ (->keymap-datum (%lookup-key (list comtab) keys))))
+
+(define (%lookup-key comtabs chars)
+ (cond ((null? chars)
+ ;; GNU Emacs 18.58 doesn't signal if `key' is ""!
+ false)
+ ((null? (cdr chars))
+ (lookup-key comtabs (car chars)))
+ (else
+ (let loop ((prefix (list (car chars)))
+ (rest (cdr chars)))
+ (if (null? (cdr rest))
+ (lookup-key comtabs chars)
+ (let ((value (lookup-key comtabs prefix)))
+ (if (command? value)
+ (length prefix)
+ (loop (append! prefix (list (car rest)))
+ (cdr rest)))))))))
+
+(define (->keymap-datum datum)
+ (cond ((not datum) '())
+ ((number? datum) datum)
+ ((comtab? datum) datum)
+ ((command&comtab? datum) (cdr datum))
+ ((anonymous-elisp-command? datum)
+ (car ((command-interactive-specification datum))))
+ ((command? datum)
+ (let ((symbol (%intern-soft (command-name datum)
+ (%symbol-value Qobarray))))
+ (if (eq? datum
+ (and (%symbol? symbol)
+ (%symbol-command symbol)))
+ symbol
+ datum)))
+ (else (error:wrong-type-datum datum "comtab definition"))))
+\f
+(DEFUN (el:key-binding keys)
+ "Return the definition for command KEYS in current keymaps.
+KEYS is a string, a sequence of keystrokes.
+The definition is probably a symbol with a function definition."
+ ;; If there's no local map, and `keys' has too many characters, GNU
+ ;; Emacs' key-binding can return an integer, but I can't bring
+ ;; myself to simulate that.
+ (let ((keys (emacs-keys->edwin-keys (CHECK-STRING keys)))
+ (comtabs (buffer-comtabs (%current-buffer))))
+ (let ((value (->keymap-datum (%lookup-key comtabs keys))))
+ (if (number? value)
+ '()
+ value))))
+
+(DEFUN (el:local-key-binding keys)
+ "Return the definition for command KEYS in current local keymap only.
+KEYS is a string, a sequence of keystrokes.
+The definition is probably a symbol with a function definition."
+ (let ((comtab (%local-comtab)))
+ (if (not comtab)
+ '()
+ (el:lookup-key comtab keys))))
+
+(DEFUN (el:global-key-binding keys)
+ "Return the definition for command KEYS in current global keymap only.
+KEYS is a string, a sequence of keystrokes.
+The definition is probably a symbol with a function definition."
+ (el:lookup-key (%global-comtab) keys))
+
+(DEFUN (el:global-set-key keys function)
+ "Give KEY a definition of COMMAND.
+COMMAND is a symbol naming an interactively-callable function.
+KEY is a string representing a sequence of keystrokes.
+Note that if KEY has a local definition in the current buffer
+that local definition will continue to shadow any global definition."
+ (interactive "kSet key globally: \nCSet key %s to command: ")
+ (el:define-key (%global-comtab) keys function)
+ '())
+
+(DEFUN (el:local-set-key keys function)
+ "Give KEY a local definition of COMMAND.
+COMMAND is a symbol naming an interactively-callable function.
+KEY is a string representing a sequence of keystrokes.
+The definition goes in the current buffer's local map,
+which is shared with other buffers in the same major mode."
+ (interactive "kSet key locally: \nCSet key %s locally to command: ")
+ (el:define-key (%local-comtab-create) keys function)
+ '())
+
+(DEFUN (el:global-unset-key keys)
+ "Remove global definition of KEY.
+KEY is a string representing a sequence of keystrokes."
+ (interactive "kUnset key globally: ")
+ (el:global-set-key keys '()))
+
+(DEFUN (el:local-unset-key keys)
+ "Remove local definition of KEY.
+KEY is a string representing a sequence of keystrokes."
+ (interactive "kUnset key locally: ")
+ (let ((comtab (%local-comtab)))
+ (if (not comtab)
+ '()
+ (el:define-key comtab keys '())))
+ '())
+
+(DEFUN (el:define-prefix-command name)
+ "Define SYMBOL as a prefix command.
+A keymap is created and stored as SYMBOL's function definition."
+ (let ((symbol (CHECK-SYMBOL name)))
+ (%set-symbol-function! symbol (make-comtab))
+ symbol))
+
+(DEFUN (el:use-global-map keymap)
+ "Selects KEYMAP as the global keymap."
+ (let ((comtab (CHECK-KEYMAP keymap)))
+ (%use-global-comtab! comtab))
+ '())
+
+(DEFUN (el:use-local-map keymap)
+ "Selects KEYMAP as the local keymap.
+nil for KEYMAP means no local keymap."
+ (%use-local-comtab! (CHECK-KEYMAP keymap))
+ '())
+
+(DEFUN (el:current-local-map)
+ "Return current buffer's local keymap, or nil if it has none."
+ (or (%local-comtab) '()))
+
+(DEFUN (el:current-global-map)
+ "Return the current global keymap."
+ (%global-comtab))
+\f
+(DEFUN (el:accessible-keymaps startmap)
+ "Find all keymaps accessible via prefix characters from KEYMAP.
+Returns a list of elements of the form (KEYS . MAP), where the sequence
+KEYS starting from KEYMAP gets you to MAP. These elements are ordered
+so that the KEYS increase in length. The first element is (\"\" . KEYMAP)."
+ ;; This is a breadth-first search with `queue' being a FIFO of (prefix .
+ ;; comtab)'s to explore next.
+ (let ((comtab (CHECK-KEYMAP startmap)))
+ (let loop ((prefix "")
+ (alist (comtab-alist* comtab))
+ (queue '())
+ (result (list (cons "" comtab))))
+ (if (not (pair? alist))
+ (if (not (pair? queue))
+ ;; Alist of current comtab AND queue exhausted -- done!
+ (reverse! result)
+ ;; Next queued comtab and prefix.
+ (loop (caar queue)
+ (comtab-alist* (cdar queue))
+ (cdr queue)
+ result))
+ (let ((entry (cond ((and (comtab? (cdar alist))
+ (char-ascii? (caar alist)))
+ (cons (string-append-char prefix (caar alist))
+ (cdar alist)))
+ ((and (command&comtab? (cdar alist))
+ (char-ascii? (caar alist)))
+ (cons (string-append-char prefix (caar alist))
+ (cdr (cdar alist))))
+ (else false))))
+ (if entry
+ (loop prefix
+ (cdr alist)
+ (append! queue (list entry))
+ (cons entry result))
+ (loop prefix
+ (cdr alist)
+ queue
+ result)))))))
+
+(DEFUN (el:key-description keys)
+ "Return a pretty description of key-sequence KEYS.
+Control characters turn into \"C-foo\" sequences, meta into \"M-foo\"
+spaces are put between sequence elements, etc."
+ (let ((keys (emacs-keys->edwin-keys (CHECK-STRING keys))))
+ (if (pair? keys)
+ (apply string-append
+ (cons (emacs-key-name (car keys) true)
+ ;; (" " "<key name>"...) or ()
+ (append-map!
+ (lambda (key) (list " " (emacs-key-name key true)))
+ (cdr keys))))
+ "")))
+
+(DEFUN (el:single-key-description key)
+ "Return a pretty description of command character KEY.
+Control characters turn into C-whatever, etc."
+ (let ((char (CHECK-CHAR key)))
+ (emacs-key-name char)))
+
+(DEFUN (el:text-char-description char)
+ "Return a pretty description of file-character CHAR.
+Control characters turn into \"^char\", etc."
+ (let ((char (CHECK-CHAR char)))
+ char
+ (error "unimplemented elisp function")))
+\f
+(DEFUN (el:where-is-internal definition #!optional local-keymap firstonly)
+ "Return list of key sequences that currently invoke command DEFINITION
+in KEYMAP or (current-global-map). If KEYMAP is nil, only search for
+keys in the global map.
+
+If FIRSTONLY is non-nil, returns a string representing the first key
+sequence found, rather than a list of all possible key sequences."
+ (let ((local-keymap (cond ((either-default? local-keymap)
+ (%global-comtab))
+ ((pair? local-keymap)
+ (guarantee-comtabs local-keymap
+ 'EL:WHERE-IS-INTERNAL))
+ (else (CHECK-KEYMAP local-keymap))))
+ (first-only? (not (either-default? firstonly)))
+ (results '()))
+ (call-with-current-continuation
+ (lambda (exit)
+ (for-each
+ (lambda (entry)
+ (let ((keys (if (pair? (car entry))
+ (car entry)
+ (list (car entry))))
+ (defn (cdr entry)))
+ (if (and (list-of-type? keys char?)
+ (anonymous-elisp-command? defn)
+ (let ((elisp-defn
+ (car ((command-interactive-specification defn)))))
+ (if (pair? definition)
+ (el:equal definition elisp-defn)
+ (eq? definition elisp-defn)))
+ (eq? (lookup-key local-keymap keys) defn))
+ (if first-only?
+ (exit (list->string keys))
+ (set! results (cons (list->string keys) results))))))
+ (if (pair? local-keymap)
+ (append-map! comtab->alist local-keymap)
+ (comtab->alist local-keymap)))
+ (reverse! results)))))
+
+(DEFUN (el:where-is definition)
+ "Print message listing key sequences that invoke specified command.
+Argument is a command definition, usually a symbol with a function definition."
+ (interactive "CWhere is command: ")
+ (let* ((def (CHECK-SYMBOL definition))
+ (keys (el:mapconcat
+ Qkey-description
+ (el:where-is-internal def (or (%local-comtab) '()))
+ ", ")))
+ (if (string-null? keys)
+ (el:message "%s is not on any keys" (%symbol-name def))
+ (el:message "%s is on %s" (%symbol-name def) keys)))
+ '())
+
+(DEFUN (el:describe-bindings)
+ "Show a list of all defined keys, and their definitions.
+The list is put in a buffer, which is displayed."
+ (interactive "")
+ (let ((buffer (%current-buffer)))
+ (%with-output-to-temp-buffer
+ "*Help*"
+ (lambda ()
+ (call-with-output-mark
+ (buffer-point (%symbol-value Qstandard-output))
+ (lambda (port) (write-bindings (buffer-comtabs buffer) port))))))
+ '())
+
+(define (write-bindings comtabs port)
+ (let ((alists (comtabs->alists comtabs)))
+ (if (not (null? alists))
+ (let ((n
+ (+ (reduce max 0
+ (map (lambda (elements)
+ (reduce max 0
+ (map (lambda (element)
+ (string-length
+ (car element)))
+ elements)))
+ alists))
+ 2)))
+ (let ((write-element
+ (lambda (element)
+ (write-string
+ (string-append (pad-on-right-to (car element) n)
+ " "
+ (cdr element))
+ port)
+ (newline port))))
+ (let ((write-elements
+ (lambda (elements)
+ (write-element '("key" . "binding"))
+ (write-element '("---" . "-------"))
+ (for-each (lambda (elements)
+ (newline)
+ (for-each write-element elements))
+ (sort-by-prefix elements)))))
+ (write-elements (car alists))
+ (for-each (lambda (elements)
+ (newline)
+ (write-elements elements))
+ (cdr alists))))))))
+
+#|(DEFUN (el:apropos string #!optional pred noprint)
+ "Show all symbols whose names contain match for REGEXP.
+If optional arg PRED is non-nil, (funcall PRED SYM) is done
+for each symbol and a symbol is mentioned if that returns non-nil.
+Returns list of symbols found; if third arg NOPRINT is non-nil,
+does not display them, just returns the list."
+ (interactive "sApropos: "))|#
+
+(DEFVAR Qglobal-map
+ unassigned
+ "Default global keymap mapping Emacs keyboard input into commands.
+The value is a keymap which is usually (but not necessarily) Emacs's
+global map."
+ (lambda ()
+ (%global-comtab))
+ (lambda (value)
+ (let ((comtab (CHECK-KEYMAP value)))
+ (%use-global-comtab! comtab)
+ comtab)))
+
+;; (comtab-get (%global-comtab) (remap-alias-key #\ESC))
+;; Value: #[command 1015]
+;; (ref-command-object meta-prefix)
+;; Value: #[command 1015]
+(DEFVAR Qesc-map
+ (make-comtab)
+ "Default keymap for ESC (meta) commands.
+The normal global definition of the character ESC indirects to this keymap.
+
+NOTE: This variable is not supported by Edwin.")
+
+(DEFVAR Qctl-x-map
+ unassigned
+ "Default keymap for C-x commands.
+The normal global definition of the character C-x indirects to this keymap.
+
+NOTE: This variable can only be a comtab in Edwin."
+ (lambda ()
+ (comtab-get (%global-comtab) (remap-alias-key #\C-x)))
+ (lambda (value)
+ (comtab-put! (%global-comtab) (remap-alias-key #\C-x)
+ (CHECK-KEYMAP value))))
+
+(DEFVAR Qminibuffer-local-map
+ (car (mode-comtabs (ref-mode-object minibuffer-local)))
+ "Default keymap to use when reading from the minibuffer.")
+
+(DEFVAR Qminibuffer-local-ns-map
+ (car (mode-comtabs (ref-mode-object minibuffer-local-noblanks)))
+ "The keymap used by the minibuf for local bindings when spaces are not
+to be allowed in input string.")
+
+(DEFVAR Qminibuffer-local-completion-map
+ (car (mode-comtabs (ref-mode-object minibuffer-local-completion)))
+ "Keymap to use when reading from the minibuffer with completion.")
+
+(DEFVAR Qminibuffer-local-must-match-map
+ (car (mode-comtabs (ref-mode-object minibuffer-local-must-match)))
+ "Keymap to use when reading from the minibuffer with completion and
+an exact match of one of the completions is required.")
+\f
+;;;; Utilities
+
+;; I'm just guessing but...
+;; It would seem that a major mode can have a list of comtabs. Setting a
+;; buffer's major mode initializes the buffer's list of comtabs to the
+;; major mode's comtabs.
+;; A minor mode can have one comtab. Enabling a minor mode in a buffer
+;; prepends the minor mode's comtab to the buffer's list of comtabs.
+;;
+;; An anonymous elisp mode, created to hold the local-keymap, will
+;; be a major mode with a list of one or two comtabs, depending on whether
+;; there currently is a local-keymap. When adding or removing a
+;; 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 (guarantee-elisp-mode! buffer)
+ (let ((mode (buffer-major-mode buffer)))
+ (if (elisp-mode? mode)
+ mode
+ (let ((elisp-mode (%make-mode (string->symbol "anonymous el:mode")
+ (list (%global-comtab)))))
+ (set-mode-display-name! elisp-mode "Fundamental")
+ (set-mode-major?! elisp-mode true)
+ (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>).")
+ (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-buffer-major-mode! buffer elisp-mode)
+ elisp-mode))))
+
+
+;;; global and local keymaps
+
+(define (%global-comtab)
+ (car (mode-comtabs (ref-mode-object fundamental))))
+
+(define (%use-global-comtab! comtab)
+ ;(set-car! (mode-comtabs (ref-mode-object fundamental)) comtab)
+ comtab
+ (error "Are you sure you want to override the global keymap?"))
+
+(define elisp-mode-local-comtab-tag "elisp-local-comtab")
+
+(define (%local-comtab #!optional mode)
+ ;; Returns false if no local comtab.
+ ;; ELisp modes might not have one. Edwin modes never do.
+ (let ((mode (if (default-object? mode)
+ (buffer-major-mode (%current-buffer))
+ mode)))
+ (if (elisp-mode? mode)
+ ;; If one comtab (the global comtab), there's no local-map.
+ (if (null? (cdr (mode-comtabs mode)))
+ false
+ (car (mode-comtabs mode)))
+ false)))
+
+(define (%use-local-comtab! comtab)
+ (let* ((mode (guarantee-elisp-mode! (%current-buffer)))
+ (shared-pair (mode-comtabs mode)))
+ (cond ((comtab? comtab)
+ (if (null? (cdr shared-pair))
+ (set-cdr! shared-pair (list (car shared-pair))))
+ (set-car! shared-pair comtab))
+ ((not comtab)
+ (if (pair? (cdr shared-pair))
+ (set-car! shared-pair (cadr shared-pair)))
+ (set-cdr! shared-pair '()))
+ (else (error:wrong-type-datum comtab "a comtab or false")))))
+
+(define (%local-comtab-create)
+ (let* ((mode (guarantee-elisp-mode! (%current-buffer)))
+ (shared-pair (mode-comtabs mode)))
+ (if (null? (cdr shared-pair))
+ (let ((new-comtab (make-comtab)))
+ (set-cdr! shared-pair (list (car shared-pair)))
+ (set-car! shared-pair new-comtab)
+ new-comtab)
+ (car shared-pair))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Fundamental definitions for GNU Emacs Lisp interpreter. |#
+
+(declare (usual-integrations))
+\f
+(declare (integrate-operator CHECK-LIST))
+(define (CHECK-LIST x)
+ (if (or (pair? x) (null? x))
+ x
+ (wrong-type-argument Qlistp x)))
+
+(declare (integrate-operator CHECK-STRING))
+(define (CHECK-STRING x)
+ (if (string? x)
+ x
+ (wrong-type-argument Qstringp x)))
+
+(define (CHECK-STRINGS x)
+ (let loop ((unchecked x)(checked '()))
+ (if (pair? unchecked)
+ (loop (cdr unchecked)
+ (cons (CHECK-STRING (car unchecked))
+ checked))
+ (reverse! checked))))
+
+(declare (integrate-operator CHECK-CONS))
+(define (CHECK-CONS x)
+ (if (pair? x)
+ x
+ (wrong-type-argument Qconsp x)))
+
+(declare (integrate-operator CHECK-SYMBOL))
+(define (CHECK-SYMBOL x)
+ (if (%symbol? x)
+ x
+ (wrong-type-argument Qsymbolp x)))
+
+(declare (integrate-operator CHECK-VECTOR))
+(define (CHECK-VECTOR x)
+ (if (vector? x)
+ x
+ (wrong-type-argument Qvectorp x)))
+
+(declare (integrate-operator CHECK-BUFFER))
+(define (CHECK-BUFFER x)
+ (if (buffer? x)
+ x
+ (wrong-type-argument Qbufferp x)))
+
+(declare (integrate-operator CHECK-WINDOW))
+(define (CHECK-WINDOW x)
+ (if (buffer-frame? x)
+ x
+ (wrong-type-argument Qwindowp x)))
+
+(declare (integrate-operator CHECK-PROCESS))
+(define (CHECK-PROCESS x)
+ (if (process? x)
+ x
+ (wrong-type-argument Qprocessp x)))
+
+(define (CHECK-PROCESS-COERCE x)
+ ;; Ala get_process in process.c.
+ (let ((proc (if (null? x)
+ (el:get-buffer-process (%current-buffer))
+ (let ((proc (el:get-process x)))
+ (if (null? proc)
+ (el:get-buffer-process (el:get-buffer x))
+ proc)))))
+ (if (process? proc)
+ proc
+ (CHECK-PROCESS-COERCE
+ (error:%signal
+ Qerror
+ (if (null? x)
+ (list "Current buffer has no process")
+ (list "Process %s does not exist" x)))))))
+
+(declare (integrate-operator CHECK-NUMBER))
+(define (CHECK-NUMBER x)
+ (if (integer? x)
+ x
+ (wrong-type-argument Qintegerp x)))
+
+(declare (integrate-operator CHECK-NATNUM))
+(define (CHECK-NATNUM x)
+ (if (and (integer? x) (>= x 0))
+ x
+ (wrong-type-argument Qnatnump x)))
+
+(declare (integrate-operator CHECK-CHAR))
+(define (CHECK-CHAR x)
+ (ascii->char (modulo (CHECK-NUMBER x) 255)))
+
+(declare (integrate-operator CHECK-MARKER))
+(define (CHECK-MARKER x)
+ (if (mark? x)
+ x
+ (wrong-type-argument Qmarkerp x)))
+
+(define (CHECK-MARKER-COERCE-INT x buffer)
+ ;; Convert from an Emacs int representing a buffer position into an
+ ;; Edwin marker.
+ (let* ((group (buffer-group buffer))
+ (min (group-start-index group))
+ (max (group-end-index group))
+ (pt (CHECK-POSITION-COERCE-MARKER x)))
+ (make-mark
+ group
+ (cond ((< pt min) min)
+ ((> pt max) max)
+ (else pt)))))
+
+(define (CHECK-NUMBER-COERCE-MARKER x)
+ ;; Convert from an Emacs int or marker into a number.
+ (cond ((integer? x) x)
+ ((mark? x)
+ (%mark->number x))
+ (else
+ (CHECK-NUMBER-COERCE-MARKER
+ (wrong-type-argument Qinteger-or-marker-p x)))))
+
+(define (CHECK-POSITION-COERCE-MARKER x)
+ ;; Convert from an Emacs int or marker into a buffer position.
+ (cond ((integer? x) (-1+ x))
+ ((mark? x)
+ (if (and (mark-group x) (mark-index x))
+ (begin
+ ;; Enforce our expectation of Emacs markers.
+ (mark-permanent! x)
+ (%mark->position x))
+ (CHECK-POSITION-COERCE-MARKER
+ (error:%signal Qerror
+ (list "Marker does not point anywhere" x)))))
+ (else
+ (CHECK-POSITION-COERCE-MARKER
+ (wrong-type-argument Qinteger-or-marker-p x)))))
+
+(define (CHECK-REGION start end buffer)
+ ;; aka validate_region in GNU Emacs.
+ (let ((group (buffer-group buffer))
+ (start (CHECK-POSITION-COERCE-MARKER start))
+ (end (CHECK-POSITION-COERCE-MARKER end)))
+ (if (> start end)
+ (let ((swap start))
+ (set! start end)
+ (set! end swap)))
+ (if (let ((min (group-start-index group))
+ (max (group-end-index group)))
+ (and (<= min start) (<= start end) (<= end max)))
+ (make-region (make-mark group start) (make-mark group end))
+ (let loop ()
+ (error:%signal Qargs-out-of-range (list start end))
+ (loop)))))
+
+(declare (integrate-operator CHECK-COMPLETION-TABLE))
+(define (CHECK-COMPLETION-TABLE table)
+ (if (completion-table? table)
+ table
+ (wrong-type-argument Qcompletion-table-p table)))
+
+(DEFUN (el:completion-table-p object)
+ "T if OBJECT is an alist or obarray."
+ (if (completion-table? object) Qt '()))
+
+(define (completion-table? object)
+ (cond ((pair? object)
+ (for-all? object
+ (lambda (entry)
+ (and (pair? entry) (string? (car entry))))))
+ ((vector? object)
+ (for-all-elts? object
+ (lambda (element)
+ (or (%symbol? element) (zero? element)))))
+ (else false)))
+
+(define (for-all-elts? vector predicate)
+ (let ((length (vector-length vector)))
+ (let loop ((index 0))
+ (if (< index length)
+ (let ((element (vector-ref vector index)))
+ (if (predicate element)
+ (loop (1+ index))
+ false))
+ true))))
+
+(declare (integrate-operator CHECK-KEYMAP))
+(define (CHECK-KEYMAP keymap)
+ (let ((comtab (keymap->comtab keymap)))
+ (or comtab
+ (wrong-type-argument Qkeymapp keymap))))
+
+(define (keymap->comtab keymap)
+ (let loop ((object keymap))
+ (cond ((comtab? object) object)
+ ((and (%symbol? object)
+ (%symbol-fbound? object))
+ (loop (%symbol-function object)))
+ (else false))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Lisp parsing and input streams. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:read-char)
+ "Read a character from the command input (keyboard or macro).
+It is returned as a number."
+ (char->ascii (keyboard-read-char)))
+
+(DEFVAR Qload-in-progress
+ '()
+ "Non-nil iff inside of load.")
+
+(define (init-load-path)
+ (let loop
+ ((lpath '())
+ (path (or (get-environment-variable "EMACSLOADPATH")
+ "/usr/local/emacs/lisp")))
+ (if (zero? (string-length path))
+ (reverse! lpath)
+ (let ((p (string-find-next-char path #\:)))
+ (if p
+ (loop (cons (string-head path p) lpath)
+ (string-tail path (1+ p)))
+ (loop (cons path lpath) ""))))))
+
+(DEFVAR Qload-path
+ (init-load-path)
+ "*List of directories to search for files to load.
+Each element is a string (directory name) or nil (try default directory).
+Initialized based on EMACSLOADPATH environment variable, if any,
+otherwise to default specified in init-load-path of lread.scm.")
+
+(define (%for-pathnames name prefixes suffixes receiver)
+ (let prefix-loop ((prefixes prefixes))
+ (if (pair? prefixes)
+ (let ((filename
+ (let ((filename (el:expand-file-name name (car prefixes))))
+ (if (pathname-absolute? (->pathname filename))
+ filename
+ (el:expand-file-name filename (el:symbol-value
+ Qdefault-directory))))))
+ (if (pathname-absolute? (->pathname filename))
+ (let suffix-loop ((suffixes suffixes))
+ (if (pair? suffixes)
+ (begin
+ (receiver (string-append filename (car suffixes)))
+ (suffix-loop (cdr suffixes)))
+ (prefix-loop (cdr prefixes))))
+ (prefix-loop (cdr prefixes))))
+ unspecific)))
+
+(define (%open? path str suffixes)
+ (call-with-current-continuation
+ (lambda (return)
+ (%for-pathnames
+ str path suffixes
+ (lambda (filename)
+ (call-with-current-continuation
+ (lambda (continue)
+ (bind-condition-handler
+ (list condition-type:error)
+ (lambda (condition)
+ condition
+ (continue false))
+ (lambda ()
+ (return (open-input-file filename))))))))
+ false)))
+
+(DEFVAR Qstandard-input
+ Qt
+ "Stream for read to get input from.
+See documentation of read for possible values.")
+
+(define (elisp-stream->input-port stream)
+ (let ((stream (if (null? stream)
+ (%symbol-value Qstandard-input)
+ stream)))
+ (cond ((input-port? stream) stream)
+ ((buffer? stream)
+ (make-buffer-input-port (buffer-start stream)
+ ;; Note: doesn't follow buffer-end!
+ (buffer-end stream)))
+ ((mark? stream)
+ (make-buffer-input-port stream
+ (group-end-mark (mark-group stream))))
+ ((string? stream)
+ (string->input-port stream))
+ ((and (procedure? stream)
+ (procedure-arity-valid? stream 0))
+ (make-%function-input-port stream))
+ ((eq? stream Qt)
+ (string->input-port (el:read-from-minibuffer
+ "Lisp expression: " '())))
+ (else (error:%signal Qinvalid-function (list stream))))))
+
+(define (make-%function-input-port function)
+ (port/copy %function-input-port/template
+ (make-%function-input-port-state function)))
+
+(define-structure (%function-input-port-state
+ (conc-name %function-input-port-state/))
+ (peeked-char false)
+ function)
+
+(define (%function-input-port/read-char port)
+ (let* ((state (port/state port))
+ (unread-char (%function-input-port-state/peeked-char state)))
+ (if unread-char
+ (begin
+ (set-%function-input-port-state/peeked-char! state ())
+ unread-char)
+ (el:funcall (%function-input-port-state/function state)))))
+
+(define (%function-input-port/peek-char port)
+ (let* ((state (port/state port))
+ (unread-char (%function-input-port-state/peeked-char state)))
+ (or unread-char
+ (let ((char
+ (el:funcall (%function-input-port-state/function state))))
+ (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))
+ ()))
+
+(DEFVAR Qvalues
+ '()
+ "List of values of all expressions which were read, evaluated and printed.
+Order is reverse chronological.")
+
+(define (readevalloop stream evaluator print?)
+ (%specbind
+ (list Qstandard-input) (list stream)
+ (lambda ()
+ (let ((stdin (elisp-stream->input-port stream)))
+ (let loop ()
+ (let ((input (parse-elisp-object stdin)))
+ ;;(format true "~%Evaluating ~S" input)
+ (if (eof-object? input)
+ unspecific
+ (let ((value (evaluator input)))
+ (if print?
+ (begin
+ (%set-symbol-value!
+ Qvalues (cons value (%symbol-value Qvalues)))
+ (if (eq? (%symbol-value Qstandard-output) Qt)
+ (el:prin1 value '())
+ (el:print value '()))))
+ (loop)))))))))
+
+(DEFUN (el:load str #!optional missing-ok nomessage nosuffix)
+ "Execute a file of Lisp code named FILE.
+First tries FILE with .elc appended, then tries with .el,
+ then tries FILE unmodified. Searches directories in load-path.
+If optional second arg MISSING-OK is non-nil,
+ report no error if FILE doesn't exist.
+Print messages at start and end of loading unless
+ optional third arg NOMESSAGE is non-nil.
+If optional fourth arg NOSUFFIX is non-nil, don't try adding
+ suffixes .elc or .el to the specified name FILE.
+Return t if file exists."
+ (let ((str (el:substitute-in-file-name (CHECK-STRING str)))
+ (missing-ok? (not (either-default? missing-ok)))
+ (nomessage? (not (either-default? nomessage)))
+ (nosuffix? (not (either-default? nosuffix))))
+ (if (not (zero? (string-length str)))
+ (let ((stream (%open? (%symbol-value Qload-path) str
+ (if nosuffix?
+ '("")
+ '(".elc" ".el" "")))))
+ (if (null? stream)
+ (if missing-ok?
+ '()
+ (el:load (error:%signal
+ Qfile-error
+ (list "Cannot open load file" str))
+ missing-ok? nomessage? nosuffix?))
+ (begin
+ (if (not nomessage?)
+ (message "Loading " str "..."))
+ (%specbind
+ (list Qload-in-progress)
+ (list Qt)
+ (lambda ()
+ (readevalloop stream el:eval false)))
+ (close-input-port stream)
+ (if (not nomessage?) ;(and (not noninteractive?) nomessage?)
+ (message "Loading " str "...done"))
+ Qt))))))
+
+(DEFUN (el:eval-current-buffer #!optional printflag)
+ "Execute the current buffer as Lisp code.
+Programs can pass argument PRINTFLAG which controls printing of output:
+nil means discard it; anything else is stream for print."
+ (interactive "")
+ (let ((print? (not (either-default? printflag))))
+ (%specbind
+ (list Qstandard-output)
+ (list (if print? '() Qsymbolp))
+ (lambda ()
+ (%save-excursion
+ (lambda ()
+ (let ((buffer (%current-buffer)))
+ (set-buffer-point! buffer (buffer-start buffer))
+ (readevalloop buffer el:eval print?)))))))
+ '())
+
+(DEFUN (el:eval-region b e #!optional printflag)
+ "Execute the region as Lisp code.
+When called from programs, expects two arguments,
+giving starting and ending indices in the current buffer
+of the text to be executed.
+Programs can pass third argument PRINTFLAG which controls printing of output:
+nil means discard it; anything else is stream for print."
+ (interactive "r")
+ (let* ((buffer (%current-buffer))
+ (region (CHECK-REGION b e buffer))
+ (print? (not (either-default? printflag))))
+ (%specbind
+ (list Qstandard-output) (list (if print? '() Qsymbolp))
+ (lambda ()
+ (let ((kernel
+ (lambda ()
+ (with-region-clipped!
+ (group-region (buffer-group buffer))
+ (lambda ()
+ (set-buffer-point! buffer (region-start region))
+ (region-clip! region)
+ (readevalloop buffer el:eval print?))))))
+ (if (not print?)
+ (%save-excursion kernel)
+ (kernel))))))
+ '())
+
+(DEFUN (el:read #!optional stream)
+ "Read one Lisp expression as text from STREAM, return as Lisp object.
+If STREAM is nil, use the value of standard-input (which see).
+STREAM or standard-input may be:
+ a buffer (read from point and advance it)
+ a marker (read from where it points and advance it)
+ a function (call it with no arguments for each character)
+ a string (takes text from string, starting at the beginning)
+ t (read text line using minibuffer and use it)."
+ (let ((stdin (if (either-default? stream)
+ (%symbol-value Qstandard-input)
+ stream)))
+ (parse-elisp-object (elisp-stream->input-port stdin))))
+
+(DEFUN (el:read-from-string string #!optional start end)
+ "Read one Lisp expression which is represented as text by STRING.
+Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
+START and END optionally delimit a substring of STRING from which to read;
+ they default to 0 and (length STRING) respectively."
+ (let* ((string (CHECK-STRING string))
+ (end (if (either-default? start)
+ (string-length string)
+ (let ((end (CHECK-NUMBER end)))
+ (if (or (< end 0) (< (string-length string) end))
+ (error:%signal Qargs-out-of-range (list string end))
+ end))))
+ (start (if (either-default? start)
+ 0
+ (let ((start (CHECK-NUMBER start)))
+ (if (or (< start 0) (< end start))
+ (error:%signal Qargs-out-of-range
+ (list string start))
+ start)))))
+ (parse-elisp-object
+ (elisp-stream->input-port (substring string start end)))))
+
+(DEFVAR Qobarray
+ initial-obarray
+ "Symbol table for use by intern and read.
+It is a vector whose length ought to be prime for best results.
+Each element is a list of all interned symbols whose names hash in that
+bucket.")
+
+(define (check-obarray obj)
+ (if (and (vector? obj) (not (zero? (vector-length obj))))
+ obj
+ (wrong-type-argument Qvectorp obj)))
+
+(DEFUN (el:intern str #!optional obarray)
+ "Return the symbol whose name is STRING.
+A second optional argument specifies the obarray to use;
+it defaults to the value of obarray."
+ (let ((str (CHECK-STRING str))
+ (ob (check-obarray (if (either-default? obarray)
+ (el:symbol-value Qobarray)
+ obarray))))
+ (%intern str ob)))
+
+(DEFUN (el:intern-soft str #!optional obarray)
+ "Return the symbol whose name is STRING, or nil if none exists yet.
+A second optional argument specifies the obarray to use;
+it defaults to the value of obarray."
+ (let ((str (CHECK-STRING str))
+ (ob (check-obarray (if (either-default? obarray)
+ (el:symbol-value Qobarray)
+ obarray))))
+ (%intern-soft str ob)))
+
+(DEFUN (el:mapatoms function #!optional obarray)
+ "Call FUNCTION on every symbol in OBARRAY.
+OBARRAY defaults to the value of obarray."
+ (let ((obarray (check-obarray (if (either-default? obarray)
+ (el:symbol-value Qobarray)
+ obarray))))
+ (%for-symbol (lambda (symbol) (el:funcall function symbol)) obarray))
+ '())
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+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
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Markers: examining, setting and killing. |#
+
+(declare (usual-integrations))
+\f
+(define (%mark->number mark)
+ (let ((index (mark-index mark)))
+ (if index
+ (1+ index)
+ (error:%signal Qerror
+ (list "Marker does not point anywhere")))))
+
+(define (%mark->position mark)
+ (or (mark-index mark)
+ (error:%signal Qerror
+ (list "Marker does not point anywhere"))))
+
+(DEFUN (el:marker-buffer marker)
+ "Return the buffer that MARKER points into, or nil if none.
+Returns nil if MARKER points into a dead buffer."
+ (let* ((group (mark-group (CHECK-MARKER marker)))
+ (buffer (and group (group-buffer group))))
+ (if (and buffer (buffer-alive? buffer))
+ buffer
+ '())))
+
+(DEFUN (el:marker-position marker)
+ "Return the position MARKER points at, as a character number."
+ (let ((index (mark-index (CHECK-MARKER marker))))
+ (if index
+ (1+ index)
+ '())))
+
+(DEFUN (el:set-marker marker pos #!optional buffer)
+ "Position MARKER before character number NUMBER in BUFFER.
+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))
+ (buffer (if (either-default? buffer)
+ (%current-buffer)
+ (CHECK-BUFFER buffer)))
+ (new-index (if (null? pos)
+ false
+ (mark-index (CHECK-MARKER-COERCE-INT pos buffer))))
+ (set-mark-group!
+ (lambda (mark group)
+ (%record-set! mark 1 group))))
+ (if new-index
+ (let ((old-group (mark-group old-marker))
+ (new-group (buffer-group buffer)))
+ (if (and old-group
+ (not (eq? old-group new-group)))
+ (mark-temporary! mark))
+ (set-mark-index! marker new-index)
+ (set-mark-group! marker new-group)
+ (mark-permanent! marker))
+ (begin
+ (mark-temporary! marker)
+ (set-mark-group! marker false)
+ (set-mark-index! marker false)))
+ old-marker))
+
+(DEFUN (el:copy-marker marker)
+ "Return a new marker pointing at the same place as MARKER.
+If argument is a number, makes a new marker pointing
+at that position in the current buffer."
+ (let ((marker (CHECK-MARKER-COERCE-INT marker (%current-buffer))))
+ (mark-permanent! marker)))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Minibuffer input and completion.
+
+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
+
+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. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:read-from-minibuffer prompt #!optional initial-input keymap read)
+ "Read a string from the minibuffer, prompting with string PROMPT.
+If optional second arg INITIAL-CONTENTS is non-nil, it is a string
+ to be inserted into the minibuffer before reading input.
+Third arg KEYMAP is a keymap to use whilst reading; the default is
+ minibuffer-local-map.
+If fourth arg READ is non-nil, then interpret the result as a lisp object
+ and return that object (ie (car (read-from-string <input-string>)))"
+ (let ((prompt (CHECK-STRING prompt))
+ (initial-input (if (either-default? initial-input)
+ ""
+ (CHECK-STRING initial-input)))
+ (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)))))))
+
+(DEFUN (el:read-minibuffer prompt #!optional initial-contents)
+ "Return a Lisp object read using the minibuffer.
+Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
+is a string to insert in the minibuffer before reading."
+ (el:read-from-minibuffer prompt
+ (if (default-object? initial-contents)
+ false
+ initial-contents)
+ (%symbol-value Qminibuffer-local-map)
+ Qt))
+
+(DEFUN (el:eval-minibuffer prompt #!optional initial-contents)
+ "Return value of Lisp expression read using the minibuffer.
+Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
+is a string to insert in the minibuffer before reading."
+ (el:eval (el:read-minibuffer prompt (if (default-object? initial-contents)
+ false
+ initial-contents))))
+
+(DEFUN (el:read-string prompt #!optional initial-input)
+ "Read a string from the minibuffer, prompting with string PROMPT.
+If non-nil second arg INITIAL-INPUT is a string to insert before reading."
+ (el:read-from-minibuffer prompt (if (default-object? initial-input)
+ false
+ initial-input)))
+
+(DEFUN (el:read-no-blanks-input prompt init)
+ "Args PROMPT and INIT, strings. Read a string from the terminal, not allowing blanks.
+Prompt with PROMPT, and provide INIT as an initial value of the input string."
+ (el:read-from-minibuffer prompt init
+ (%symbol-value Qminibuffer-local-ns-map)))
+
+(DEFUN (el:read-command prompt)
+ "Args PROMPT and INIT, strings. Read a string from the terminal, not allowing blanks.
+Prompt with PROMPT, and provide INIT as an initial value of the input string."
+ (let ((obarray (%symbol-value Qobarray)))
+ (%intern (el:completing-read prompt obarray Qcommandp Qt '()) obarray)))
+
+(DEFUN (el:read-variable prompt)
+ "One arg PROMPT, a string. Read the name of a user variable and return
+it as a symbol. Prompts with PROMPT.
+A user variable is one whose documentation starts with a \"*\" character."
+ (let ((obarray (%symbol-value Qobarray)))
+ (%intern (el:completing-read prompt obarray Quser-variable-p Qt '())
+ obarray)))
+
+(DEFUN (el:read-buffer prompt #!optional default require-match)
+ "One arg PROMPT, a string. Read the name of a buffer and return as a string.
+Prompts with PROMPT.
+Optional second arg is value to return if user enters an empty line.
+If optional third arg REQUIRE-MATCH is non-nil, only existing buffer names are allowed."
+ (let* ((default (if (buffer? default) (buffer-name default) default))
+ (prompt (el:format "%s(default %s) " prompt default))
+ (tem (el:completing-read prompt buffer-alist '()
+ (if (default-object? require-match)
+ false
+ require-match)
+ '())))
+ (if (zero? (string-length tem))
+ default
+ tem)))
+
+(DEFUN (el:try-completion string alist #!optional pred)
+ "Return common substring of all completions of STRING in ALIST.
+Each car of each element of ALIST is tested to see if it begins with STRING.
+All that match are compared together; the longest initial sequence
+common to all matches is returned as a string.
+If there is no match at all, nil is returned.
+For an exact match, t is returned.
+
+ALIST can be an obarray instead of an alist.
+Then the print names of all symbols in the obarray are the possible matches.
+
+If optional third argument PREDICATE is non-nil,
+it is used to test each possible match.
+The match is a candidate only if PREDICATE returns non-nil.
+The argument given to PREDICATE is the alist element or the symbol from the obarray."
+ (let ((string (CHECK-STRING string))
+ (pred (if (default-object? pred) false pred)))
+ (if (and (not (pair? alist)) (not (vector? alist)))
+ (el:funcall alist string (or pred '()) '())
+ (let ((completion (%try-completion string alist pred)))
+ (case completion
+ (#f '())
+ (#t Qt)
+ (else completion))))))
+
+(define (alist-or-obarray-map alist-obarray receiver)
+ (if (pair? alist-obarray)
+ (for-each (lambda (elt)
+ (let ((elt-string (CHECK-STRING (car elt))))
+ (receiver elt-string elt)))
+ alist-obarray)
+ (%for-symbol (lambda (symbol)
+ (receiver (%symbol-name symbol) symbol))
+ alist-obarray)))
+
+(define (prefix? prefix string)
+ (if (null? (%symbol-value Qcompletion-ignore-case))
+ (string-prefix? prefix string)
+ (string-prefix-ci? prefix string)))
+
+(define (%try-completion string alist pred)
+ (let ((match (lambda (s1 s2)
+ (if (null? (%symbol-value Qcompletion-ignore-case))
+ (string-match-forward s1 s2)
+ (string-match-forward-ci s1 s2))))
+ (matchcount 0)
+ (bestmatch false)
+ (bestmatchsize 0))
+ (alist-or-obarray-map
+ alist
+ (lambda (eltstring elt)
+ (if (and (prefix? string eltstring)
+ (if pred (not (null? (el:funcall pred elt))) true))
+ (begin
+ (set! matchcount (1+ matchcount))
+ (if (not bestmatch)
+ (begin
+ (set! bestmatch eltstring)
+ (set! bestmatchsize (string-length eltstring)))
+ (set! bestmatchsize (match bestmatch eltstring)))))))
+ (cond ((not bestmatch)
+ false)
+ ((and (= 1 matchcount)
+ (= bestmatchsize (string-length string)))
+ true)
+ (else (string-head bestmatch bestmatchsize)))))
+
+(DEFUN (el:all-completions string alist #!optional pred)
+ "Search for partial matches to STRING in ALIST.
+Each car of each element of ALIST is tested to see if it begins with STRING.
+The value is a list of all the strings from ALIST that match.
+ALIST can be an obarray instead of an alist.
+Then the print names of all symbols in the obarray are the possible matches.
+
+If optional third argument PREDICATE is non-nil,
+it is used to test each possible match.
+The match is a candidate only if PREDICATE returns non-nil.
+The argument given to PREDICATE is the alist element or the symbol from the obarray."
+ (let ((string (CHECK-STRING string))
+ (pred (if (default-object? pred) false pred)))
+ (if (and (not (pair? alist)) (not (vector? alist)))
+ (el:funcall alist string (or pred '()) '())
+ (%all-completions string alist pred))))
+
+(define (%all-completions string alist pred)
+ (let ((allmatches '()))
+ (alist-or-obarray-map
+ alist
+ (lambda (eltstring elt)
+ (if (and (prefix? string eltstring)
+ (if pred (not (null? (el:funcall pred elt))) true))
+ (set! allmatches (cons eltstring allmatches)))))
+ (reverse! allmatches)))
+
+(DEFUN (el:completing-read prompt table #!optional pred require-match init)
+ "Read a string in the minibuffer, with completion.
+Args are PROMPT, TABLE, PREDICATE, REQUIRE-MATCH and INITIAL-INPUT.
+PROMPT is a string to prompt with; normally it ends in a colon and a space.
+TABLE is an alist whose elements' cars are strings, or an obarray (see try-completion).
+PREDICATE limits completion to a subset of TABLE; see try-completion for details.
+If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
+ the input is (or completes to) an element of TABLE.
+ If it is also not t, Return does not exit if it does non-null completion.
+If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
+Case is ignored if ambient value of completion-ignore-case is non-nil."
+ (let ((prompt (CHECK-STRING prompt))
+ (table (CHECK-COMPLETION-TABLE table))
+ (pred (if (default-object? pred) false pred))
+ (require-match? (if (either-default? require-match)
+ false
+ require-match))
+ (init (if (either-default? init)
+ ""
+ (CHECK-STRING init))))
+ (%specbind
+ (list Qhelp-form
+ Qminibuffer-completion-table
+ Qminibuffer-completion-predicate
+ Qminibuffer-completion-confirm)
+ (list (%symbol-value Qminibuffer-help-form)
+ table
+ pred
+ (if (eq? require-match? Qt) '() Qt))
+ (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)))))))))
+
+(DEFUN (el:minibuffer-complete)
+ "Complete the minibuffer contents as far as possible."
+ (interactive "")
+ ((ref-command minibuffer-complete)))
+
+(DEFUN (el:minibuffer-complete-and-exit)
+ "Complete the minibuffer contents, and maybe exit.
+Exit if the name is valid with no completion needed.
+If name was completed to a valid match,
+a repetition of this command will exit."
+ (interactive "")
+ ((ref-command minibuffer-complete-and-exit)))
+
+(DEFUN (el:minibuffer-complete-word)
+ "Complete the minibuffer conotents at most a single-word."
+ (interactive "")
+ ((ref-command minibuffer-complete-word)))
+\f
+(DEFUN (el:display-completion-list completions)
+ "Display in a buffer the list of completions, COMPLETIONS.
+Each element may be just a symbol or string
+or may be a list of two strings to be printed as if concatenated."
+ (interactive "")
+ (pop-up-generated-completions
+ (lambda ()
+ (map (lambda (elt)
+ (cond ((string? elt) elt)
+ ((%symbol? elt) (%symbol-name elt))
+ ((and (pair? elt) (string? (car elt))
+ (pair? (cdr elt)) (string? (car (cdr elt)))
+ (null? (cdr (cdr elt))))
+ (string-append (car elt)
+ (car (cdr elt))))
+ (else (write-to-string elt))))
+ completions))))
+
+(DEFUN (el:minibuffer-completion-help)
+ "Display a list of possible completions of the current minibuffer contents."
+ (interactive "")
+ ((ref-command minibuffer-completion-help)))
+\f
+(DEFUN (el:self-insert-and-exit)
+ "Terminate minibuffer input."
+ (interactive "")
+ (let* ((buffer (%current-buffer))
+ (point (buffer-point buffer)))
+ (%fixup-window-point-movement
+ buffer point
+ (insert-chars (current-command-key) 1 point)))
+ (exit-typein-edit))
+
+(DEFUN (el:exit-minibuffer)
+ "Terminate this minibuffer argument."
+ (interactive "")
+ ((ref-command exit-minibuffer)))
+
+(DEFUN (el:minibuffer-depth)
+ "Return current depth of activations of minibuffer, a nonnegative integer."
+ (1+ typein-edit-depth))
+\f
+(DEFVAR Qcompletion-auto-help
+ unassigned
+ "*Non-nil means automatically provide help for invalid completion input.
+
+NOTE: This variable can only be a boolean in Edwin."
+ (boolean-getter (ref-variable completion-auto-help))
+ (boolean-setter (ref-variable completion-auto-help)))
+
+(DEFVAR Qcompletion-ignore-case
+ '()
+ "Non-nil means don't consider case significant in completion.")
+
+(DEFVAR Qenable-recursive-minibuffers
+ unassigned
+ "*Non-nil means to allow minibuffers to invoke commands which use
+recursive minibuffers.
+
+NOTE: This variable can only be a boolean in Edwin."
+ (boolean-getter (ref-variable enable-recursive-minibuffers))
+ (boolean-setter (ref-variable enable-recursive-minibuffers)))
+
+(DEFVAR Qminibuffer-completion-table
+ '()
+ "Alist or obarray used for completion in the minibuffer.")
+
+(DEFVAR Qminibuffer-completion-predicate
+ '()
+ "Holds PREDICATE argument to completing-read.")
+
+(DEFVAR Qminibuffer-completion-confirm
+ '()
+ "Non-nil => demand confirmation of completion before exiting minibuffer.")
+
+(DEFVAR Qminibuffer-help-form
+ '()
+ "Value that help-form takes on inside the minibuffer.
+
+NOTE: help-form is not supported by Edwin.")
+\f
+(define (keymap->mode keymap)
+ (let ((comtab (CHECK-KEYMAP
+ (let loop ((keymap keymap))
+ (if (and (%symbol? keymap)
+ (%symbol-fbound? keymap))
+ (loop (%symbol-function keymap))
+ keymap)))))
+ (cond ((eq? comtab (car (mode-comtabs
+ (ref-mode-object minibuffer-local))))
+ (ref-mode-object minibuffer-local))
+ ((eq? comtab (car (mode-comtabs
+ (ref-mode-object minibuffer-local-completion))))
+ (ref-mode-object minibuffer-local-completion))
+ ((eq? comtab (car (mode-comtabs
+ (ref-mode-object minibuffer-local-must-match))))
+ (ref-mode-object minibuffer-local-must-match))
+ ((eq? comtab (car (mode-comtabs
+ (ref-mode-object minibuffer-local-noblanks))))
+ (ref-mode-object minibuffer-local-noblanks))
+ (else
+ (let ((elisp-mode
+ (%make-mode (string->symbol "anonymous minibuffer mode")
+ (list comtab (%global-comtab)))))
+ (set-mode-display-name! elisp-mode "emacs minibuffer mode")
+ (set-mode-major?! elisp-mode true)
+ (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
+ "Major mode for editing input strings that may not contain blanks.
+The following commands are special to this mode:
+
+\\[exit-minibuffer] terminates the input.
+\\[minibuffer-yank-default] yanks the default string, if there is one.")
+
+(define-key 'minibuffer-local-noblanks #\return 'exit-minibuffer)
+(define-key 'minibuffer-local-noblanks #\linefeed 'exit-minibuffer)
+(define-key 'minibuffer-local-noblanks #\c-m-y 'minibuffer-yank-default)
+(define-key 'minibuffer-local-noblanks #\space 'exit-minibuffer)
+(define-key 'minibuffer-local-noblanks #\tab 'exit-minibuffer)
+(define-key 'minibuffer-local-noblanks #\? 'self-insert-and-exit)
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Lisp object printing and output streams. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:write-char ch #!optional printcharfun)
+ "Output character CHAR to stream STREAM.
+STREAM defaults to the value of `standard-output' (which see)."
+ (let ((char (CHECK-CHAR ch))
+ (stdout (if (either-default? printcharfun)
+ (%symbol-value Qstandard-output)
+ printcharfun)))
+ (print-substring (char->string char) 0 1 stdout)))
+
+(DEFUN (el:with-output-to-temp-buffer "e bufname . body)
+ "Binding `standard-output' to buffer named BUFNAME, execute BODY then display that buffer.
+The buffer is cleared out initially, and marked as unmodified when done.
+All output done by BODY is inserted in that buffer by default.
+It is displayed in another window, but not selected.
+The value of the last form in BODY is returned.
+If variable `temp-buffer-show-hook' is non-nil, call it at the end
+to get the buffer displayed. It gets one argument, the buffer to display."
+ (let* ((name (CHECK-STRING (el:eval bufname)))
+ (buffer (el:get-buffer-create name)))
+ (%with-output-to-temp-buffer
+ buffer
+ (lambda () (apply el:progn body)))))
+
+(define (%with-output-to-temp-buffer buffer thunk)
+ (%with-current-buffer
+ buffer
+ (lambda ()
+ (set-buffer-writable! buffer)
+ (el:erase-buffer)
+ (%specbind
+ (list Qstandard-output)
+ (list buffer)
+ (lambda ()
+ (let* ((val (thunk))
+ (hook (%symbol-value Qtemp-buffer-show-hook)))
+ (if (null? hook)
+ (let ((window (el:display-buffer buffer '())))
+ (set! *minibuffer-scroll-window* (object-hash window))
+ ;;(el:set-window-hscroll window 0)
+ (set-window-point! window (buffer-start buffer))
+ (window-scroll-y-absolute! window 0))
+ (el:funcall hook buffer))
+ val))))))
+
+(DEFUN (el:terpri #!optional printcharfun)
+ "Output a newline to STREAM (or value of standard-output)."
+ (let ((stdout (if (either-default? printcharfun)
+ (%symbol-value Qstandard-output)
+ printcharfun)))
+ (print-substring "\n" 0 1 stdout))
+ Qt)
+
+(DEFUN (el:prin1 obj #!optional printcharfun)
+ "Output the printed representation of OBJECT, any Lisp object.
+Quoting characters are printed when needed to make output that `read'
+can handle, whenever this is possible.
+Output stream is STREAM, or value of `standard-output' (which see)."
+ (let ((stdout (if (either-default? printcharfun)
+ (%symbol-value Qstandard-output)
+ printcharfun)))
+ (print obj true stdout))
+ obj)
+
+(DEFUN (el:prin1-to-string obj)
+ "Return a string containing the printed representation of OBJECT,
+any list object. Quoting characters are used when needed to make output
+that `read' can handle, whenever this is possible."
+ (let ((buffer (make-buffer "el:prin1-to-string scratch buffer"
+ (ref-mode-object fundamental)
+ (working-directory-pathname))))
+ (print obj true buffer)
+ (extract-string (buffer-start buffer) (buffer-end buffer))))
+
+(DEFUN (el:princ obj #!optional printcharfun)
+ "Output the printed representation of OBJECT, any Lisp object.
+No quoting characters are used; no delimiters are printed around
+the contents of strings.
+Output stream is STREAM, or value of standard-output (which see)."
+ (let ((stdout (if (either-default? printcharfun)
+ (%symbol-value Qstandard-output)
+ printcharfun)))
+ (print obj false stdout))
+ obj)
+
+(DEFUN (el:print obj #!optional printcharfun)
+ "Output the printed representation of OBJECT, with newlines around it.
+Quoting characters are printed when needed to make output that `read'
+can handle, whenever this is possible.
+Output stream is STREAM, or value of `standard-output' (which see)."
+ (let ((stdout (if (either-default? printcharfun)
+ (%symbol-value Qstandard-output)
+ printcharfun)))
+ (print-substring "\n" 0 1 stdout)
+ (print obj true stdout)
+ (print-substring "\n" 0 1 stdout))
+ obj)
+
+(define (print obj escape? stdout)
+ (let ((print-length (%symbol-value Qprint-length))
+ (depth 0))
+ (let print-it ((obj obj))
+ (set! depth (1+ depth))
+ (if (> depth 200)
+ (error:%signal Qerror
+ (list "Apparently circular structure being printed")))
+ (cond ((%symbol? obj) (%symbol-print obj escape? stdout))
+ ((string? obj) (string-print obj escape? stdout))
+ ((pair? obj)
+ (print-substring "(" 0 1 stdout)
+ (print-it (car obj))
+ (let loop ((i 0) (obj (cdr obj)))
+ (cond ((null? obj)
+ (print-substring ")" 0 1 stdout))
+ ((and (integer? print-length) (> i print-length))
+ (print-substring " ..." 0 4 stdout))
+ ((pair? obj)
+ (print-substring " " 0 1 stdout)
+ (print-it (car obj))
+ (loop (1+ i) (cdr obj)))
+ (else
+ (print-substring " . " 0 3 stdout)
+ (print-it obj)
+ (print-substring ")" 0 1 stdout)))))
+ ((buffer? obj)
+ (cond ((not (buffer-alive? obj))
+ (print-substring "#<killed buffer>" 0 16 stdout))
+ (escape?
+ (print-substring "#<buffer " 0 9 stdout)
+ (let ((name (buffer-name obj)))
+ (print-substring name 0 (string-length name) stdout))
+ (print-substring ">" 0 1 stdout))
+ (else
+ (let ((name (buffer-name obj)))
+ (print-substring name 0 (string-length name) stdout)))))
+ ;; Getting lazy. There're Emacs-defined print formats for
+ ;; these, but...
+ ;; ((subprocess? obj)... )
+ ;; ((window? obj)... )
+ ;; ((window-configuration? obj)... )
+ ((mark? obj)
+ (print-substring "#<marker " 0 9 stdout)
+ (if (not (mark-group obj))
+ (print-substring "in no buffer" 0 12 stdout)
+ (begin
+ (if (mark-index obj)
+ (let ((name (number->string (mark-index obj))))
+ (print-substring " at " 0 4 stdout)
+ (print-substring name 0 (string-length name) stdout)))
+ (print-substring " in " 0 4 stdout)
+ (print-it (group-buffer (mark-group obj)))))
+ (print-substring ">" 0 1 stdout))
+ ((%subr? obj)
+ (print-substring "#<subr " 0 7 stdout)
+ (let ((name (%subr-name obj)))
+ (print-substring name 0 (string-length name) stdout))
+ (print-substring ">" 0 1 stdout))
+ ;; Distinguish Scheme symbols from Emacs symbols.
+ ((symbol? obj)
+ (print-substring "#[scheme symbol " 0 16 stdout)
+ (let ((name (symbol-name obj)))
+ (print-substring name 0 (string-length name) stdout))
+ (print-substring "]" 0 1 stdout))
+ ;; In MIT-Scheme, struct's are vector's. Grrr.
+ ;; This better come next to last, with some additional checks...
+ ((and (vector? obj)
+ (or (zero? (vector-length obj))
+ (not (record-type? (vector-first obj)))))
+ (print-substring "[" 0 1 stdout)
+ (let ((len (vector-length obj)))
+ (if (not (zero? len))
+ (begin
+ (print-it (vector-ref obj 0))
+ (let loop ((i 1))
+ (if (< i len)
+ (begin
+ (print-substring " " 0 1 stdout)
+ (print-it (vector-ref obj i))
+ (loop (1+ i))))))))
+ (print-substring "]" 0 1 stdout))
+ ;; Catch-all for Scheme and some Emacs objects.
+ (else
+ (let ((str (with-output-to-string
+ (lambda ()
+ (if escape? (write obj) (display obj))))))
+ (print-substring str 0 (string-length str) stdout))))
+ (set! depth (-1+ depth)))))
+
+(define char-set:strange-symbol-chars
+ (char-set-union
+ (ascii-range->char-set 0 #o040)
+ (char-set #\" #\\ #\' #\; #\# #\( #\) #\, #\. #\` #\[ #\] #\?)))
+
+(define (%symbol-print sym escape? stdout)
+ (let* ((name (%symbol-name sym))
+ (namlen (string-length name)))
+ (if (not escape?)
+ (print-substring name 0 namlen stdout)
+ (begin
+ (if (string->number name 10)
+ (print-substring "\\" 0 1 stdout))
+ (let loop ((start 0))
+ (let ((end (or (substring-find-next-char-in-set
+ name start namlen
+ char-set:strange-symbol-chars)
+ namlen)))
+ (print-substring name start end stdout)
+ (if (< end namlen)
+ (begin
+ (print-substring "\\" 0 1 stdout)
+ (print-substring name end (1+ end) stdout)
+ (loop (1+ end)))))))))
+ unspecific)
+
+(define (string-print str escape? stdout)
+ (let ((len (string-length str))
+ (escape-newlines (%symbol-value Qprint-escape-newlines)))
+ (if escape? (print-substring "\"" 0 1 stdout))
+ (let loop ((start 0))
+ (let ((end (or (substring-find-next-char str start len #\Newline)
+ len)))
+ (print-substring str start end stdout)
+ (if (< end len)
+ (begin
+ (if (null? escape-newlines)
+ (print-substring "\n" 0 1 stdout)
+ (print-substring "\\n" 0 2 stdout))
+ (loop (1+ end))))))
+ (if escape? (print-substring "\"" 0 1 stdout)))
+ unspecific)
+
+(define (print-substring string start end stdout)
+ ;; Output a substring to Emacs' notion of stdout. `stdout' can be:
+ ;; <buffer>: insert at current point
+ ;; <marker>: insert at marker
+ ;; <oport>: write/display on port
+ ;; Qt: append to current message
+ (cond ((>= start end) unspecific)
+ ((or (mark? stdout)
+ (buffer? stdout))
+ (let ((buffer (if (buffer? stdout) stdout (mark-buffer stdout)))
+ (point (if (mark? stdout) stdout (buffer-point stdout))))
+ ;; GNU Emacs' doesn't check this and will
+ ;; die suddenly if the marker points nowhere.
+ ;; Let's not simulate that.
+ (CHECK-POSITION-COERCE-MARKER point)
+ (%fixup-window-point-movement
+ buffer point
+ (lambda () (insert-substring string start end point)))))
+ ((output-port? stdout)
+ (write-substring string start end stdout))
+ ((eq? stdout Qt)
+ (set-current-message! (string-append (current-message)
+ (substring string start end))))
+ (else (error:%signal
+ Qerror (list "invalid value for standard-output" stdout)))))
+
+(DEFVAR Qstandard-output
+ Qt
+ "Function print uses by default for outputting a character.
+This may be any function of one argument.
+It may also be a buffer (output is inserted before point)
+or a marker (output is inserted and the marker is advanced)
+or the symbol t (output appears in the minibuffer line).")
+
+(DEFVAR Qprint-length
+ '()
+ "Maximum length of list to print before abbreviating.
+`nil' means no limit.")
+
+(DEFVAR Qprint-escape-newlines
+ '()
+ "Non-nil means print newlines in strings as backslash-n.")
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Asynchronous subprocess control for GNU Emacs.
+
+
+* Notes on Emacs/Edwin subprocess status:
+
+
+** Emacs Lisp
+
+*** internally
+
+proc->status < {RUN,
+ (STOP signal#),
+ (EXIT code . core?),
+ (SIGNAL signal# . core?)}
+
+When deleted:
+proc->status = (SIGNAL SIGKILL)
+
+When network process deleted:
+proc->status = (EXIT 0)
+
+*** externally
+
+(process-status proc) < {RUN,STOP,EXIT,SIGNAL}
+(process-exit-status proc) < {0, signal#, exit_code, signal#}
+
+
+** Edwin Scheme
+
+*** Scheme subprocess
+
+(subprocess-status subproc) < {RUNNING,STOPPED,EXITED,SIGNALLED}
+(subprocess-exit-reason subproc) < {0, signal#, exit_code, signal#}
+
+*** Edwin processes
+
+(process-status proc) < {RUN,STOP,EXIT,SIGNAL}
+(process-exit-reason proc) < {0, signal#, exit_code, signal#}
+
+When deleted:
+(process-status proc) = SIGNALLED
+(process-exit-reason proc) = false... OS-specific sigkill#
+
+No network processes, yet.
+
+
+** status message
+
+Edwin's `process-status-message' is a reasonable facsimile of GNU
+Emacs'. However, GNU Emacs uses sys_siglist to _describe_ a signal
+(rather than just giving the signal number) and notes when core has
+been dumped. |#
+
+(declare (usual-integrations))
+\f
+(define Qrun (%intern "run" initial-obarray))
+(define Qstop (%intern "stop" initial-obarray))
+(define Qexit (%intern "exit" initial-obarray))
+;(define Qsignal (%intern "signal" initial-obarray))
+
+(DEFUN (el:processp obj)
+ "Return t if OBJECT is a process."
+ (if (process? obj) Qt '()))
+
+(DEFUN (el:get-process name)
+ "Return the process named NAME, or nil if there is none."
+ (if (process? name)
+ name
+ (let* ((name (CHECK-STRING name))
+ (process (get-process-by-name name)))
+ (or process '()))))
+
+(DEFUN (el:get-buffer-process name)
+ "Return the (or, a) process associated with BUFFER.
+BUFFER may be a buffer or the name of one."
+ (let ((buffer (if (null? name) '() (el:get-buffer name))))
+ (if (null? buffer)
+ '()
+ (or (get-buffer-process buffer) '()))))
+
+(DEFUN (el:delete-process proc)
+ "Delete PROCESS: kill it and forget about it immediately.
+PROCESS may be a process or the name of one, or a buffer name."
+ (let ((process (CHECK-PROCESS-COERCE proc)))
+ (delete-process process))
+ '())
+\f
+(DEFUN (el:process-status proc)
+ "Return the status of PROCESS: a symbol, one of these:
+run -- for a process that is running.
+stop -- for a process stopped but continuable.
+exit -- for a process that has exited.
+signal -- for a process that has got a fatal signal.
+open -- for a network stream connection that is open.
+closed -- for a network stream connection that is closed.
+nil -- if arg is a process name and no such process exists."
+ (let ((process (el:get-process proc)))
+ (if (null? process)
+ '()
+ (let ((status (process-status process)))
+ (case status
+ ((RUN) Qrun)
+ ((STOP) Qstop)
+ ((EXIT) Qexit)
+ ((SIGNAL) Qsignal)
+ (else (error:wrong-type-datum status
+ "a legal process status")))))))
+
+(DEFUN (el:process-exit-status proc)
+ "Return the exit status of PROCESS or the signal number that killed it.
+If PROCESS has not yet exited or died, return 0.
+If PROCESS is a net connection that was closed remotely, return 256."
+ (let ((process (CHECK-PROCESS proc)))
+ (process-exit-reason process)))
+
+(DEFUN (el:process-id proc)
+ "Return the process id of PROCESS.
+This is the pid of the Unix process which PROCESS uses or talks to.
+For a network connection, this value is nil."
+ (let ((process (CHECK-PROCESS proc)))
+ (subprocess-id (process-subprocess process))))
+
+(DEFUN (el:process-name proc)
+ "Return the name of PROCESS, as a string.
+This is the name of the program invoked in PROCESS,
+possibly modified to make it unique among process names."
+ (let ((process (CHECK-PROCESS proc)))
+ (process-name process)))
+
+(DEFUN (el:process-command proc)
+ "Return the command that was executed to start PROCESS.
+This is a list of strings, the first string being the program executed
+and the rest of the strings being the arguments given to it.
+For a non-child channel, this is nil."
+ (let ((process (CHECK-PROCESS proc)))
+ (vector->list (process-arguments process))))
+
+(DEFUN (el:set-process-buffer proc buffer)
+ "Set buffer associated with PROCESS to BUFFER (a buffer, or nil)."
+ (let ((process (CHECK-PROCESS proc))
+ (buffer (if (null? buffer)
+ false
+ (CHECK-BUFFER buffer))))
+ (set-process-buffer! process buffer)
+ buffer))
+
+(DEFUN (el:process-buffer proc)
+ "Return the buffer PROCESS is associated with.
+Output from PROCESS is inserted in this buffer
+unless PROCESS has a filter."
+ (let* ((process (CHECK-PROCESS proc))
+ (buffer (process-buffer process)))
+ (or buffer '())))
+
+(DEFUN (el:process-mark proc)
+ "Return the marker for the end of the last output from PROCESS."
+ (let ((process (CHECK-PROCESS proc)))
+ (process-mark process)))
+
+(define elisp-filters (make-1d-table))
+
+(DEFUN (el:set-process-filter proc filter)
+ "Give PROCESS the filter function FILTER; nil means no filter.
+When a process has a filter, each time it does output
+the entire string of output is passed to the filter.
+The filter gets two arguments: the process and the string of output.
+If the process has a filter, its buffer is not used for output."
+ (let ((process (CHECK-PROCESS proc)))
+ (1d-table/put! elisp-filters process filter)
+ (set-process-filter!
+ process
+ (if (null? filter)
+ false
+ (lambda (string start end)
+ (el:funcall filter process
+ (if (and (zero? start)
+ (= (length string) end))
+ string
+ (substring string start end)))))))
+ filter)
+
+(DEFUN (el:process-filter proc)
+ "Returns the filter function of PROCESS; nil if none.
+See set-process-filter for more info on filter functions."
+ (let ((process (CHECK-PROCESS proc)))
+ (1d-table/get elisp-filters process '())))
+
+(define elisp-sentinels (make-1d-table))
+
+(DEFUN (el:set-process-sentinel proc sentinel)
+ "Give PROCESS the sentinel SENTINEL; nil for none.
+The sentinel is called as a function when the process changes state.
+It gets two arguments: the process, and a string describing the change."
+ (let ((process (CHECK-PROCESS proc)))
+ (1d-table/put! elisp-sentinels process sentinel)
+ (set-process-sentinel!
+ process
+ (if (null? sentinel)
+ false
+ (lambda (process emacs-status reason)
+ (el:funcall sentinel process
+ (process-status-message emacs-status reason))))))
+ sentinel)
+
+(DEFUN (el:process-sentinel proc)
+ "Return the sentinel of PROCESS; nil if none.
+See set-process-sentinel for more info on sentinels."
+ (let ((process (CHECK-PROCESS proc)))
+ (1d-table/get elisp-sentinels process '())))
+
+(DEFUN (el:process-kill-without-query proc #!optional value)
+ "Say no query needed if PROCESS is running when Emacs is exited.
+Optional second argument if non-nil says to require a query.
+Value is t if a query was formerly required."
+ (let ((process (CHECK-PROCESS proc)))
+ (let ((new-query? (either-default? value))
+ (old-query? (process-kill-without-query process)))
+ (set-process-kill-without-query! process new-query?)
+ (if old-query? Qt '()))))
+\f
+(DEFUN (el:list-processes)
+ "Display a list of all processes.
+\(Any processes listed as Exited or Signaled are actually eliminated
+after the listing is made.)"
+ (interactive "")
+ ((ref-command list-processes)))
+
+(DEFUN (el:process-list)
+ "Return a list of all processes."
+ (process-list))
+\f
+(DEFUN (el:start-process name buffer program . program-args)
+ "Start a program in a subprocess. Return the process object for it.
+Args are NAME BUFFER PROGRAM &rest PROGRAM-ARGS
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer or (buffer-name) to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+Third arg is program file name. It is searched for as in the shell.
+Remaining arguments are strings to give program as arguments."
+ (let ((name (CHECK-STRING name))
+ (buffer (if (null? buffer) false (el:get-buffer-create buffer)))
+ (program (CHECK-STRING program))
+ (program-args (CHECK-STRINGS program-args)))
+ (bind-condition-handler
+ (list condition-type:simple-error)
+ ;; This is going to run without-interrupts, no?
+ (lambda (condition)
+ (if (string=? "Can't find program:"
+ ((condition-accessor
+ condition-type:simple-error 'MESSAGE) condition))
+ (error:%signal Qfile-error
+ (list "Searching for program"
+ "no such file or directory"
+ program))))
+ (lambda ()
+ (without-interrupts
+ (lambda ()
+ (let ((process (apply start-process
+ name
+ (or buffer ; temporary
+ (%current-buffer))
+ false ; inherit Scheme's environment
+ program
+ program-args)))
+ (if (not buffer) (set-process-buffer! process false))
+ process)))))))
+
+#| Just use GNUS's tcp.c program for now...
+(DEFUN (el:open-network-stream name buffer host service)
+ "Open a TCP connection for a service to a host.
+Returns a subprocess-object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+Args are NAME BUFFER HOST SERVICE.
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer (or buffer-name) to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+Third arg is name of the host to connect to.
+Fourth arg SERVICE is name of the service desired, or an integer
+ specifying a port number to connect to.")|#
+\f
+(define waiting-for-process-output? false)
+
+(DEFUN (el:accept-process-output #!optional proc)
+ "Allow any pending output from subprocesses to be read by Emacs.
+It is read into the process' buffers or given to their filter functions.
+Non-nil arg PROCESS means do not return until some output has been received
+from PROCESS."
+ (fluid-let ((waiting-for-process-output? true))
+ (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)))
+ (begin
+ (block-on-input-descriptor
+ (channel-descriptor-for-select
+ (subprocess-output-channel
+ (process-subprocess process))))
+ (loop))))))
+ (accept-process-output))
+ '())
+
+(DEFUN (el:waiting-for-user-input-p)
+ "Returns non-NIL if emacs is waiting for input from the user.
+This is intended for use by asynchronous process output filters and sentinels."
+ (if waiting-for-process-output? '() Qt))
+\f
+(DEFUN (el:process-send-region process start end)
+ "Send current contents of region as input to PROCESS.
+PROCESS may be a process name.
+Called from program, takes three arguments, PROCESS, START and END."
+ (let ((process (CHECK-PROCESS-COERCE process))
+ (region (CHECK-REGION start end (%current-buffer))))
+ (process-send-string process (region->string region)))
+ '())
+
+(DEFUN (el:process-send-string process string)
+ "Send PROCESS the contents of STRING as input.
+PROCESS may be a process name."
+ (let ((process (CHECK-PROCESS-COERCE process))
+ (string (CHECK-STRING string)))
+ (process-send-string process string))
+ '())
+\f
+(DEFUN (el:interrupt-process #!optional process current-group)
+ "Interrupt process PROCESS. May be process or name of one.
+Nil or no arg means current buffer's process.
+Second arg CURRENT-GROUP non-nil means send signal to
+the current process-group of the process's controlling terminal
+rather than to the process's own process group.
+If the process is a shell, this means interrupt current subjob
+rather than the shell."
+ (let ((process (CHECK-PROCESS-COERCE (if (default-object? process)
+ '()
+ process)))
+ (group? (not (either-default? current-group))))
+ (interrupt-process process group?)
+ process))
+
+(DEFUN (el:kill-process #!optional process current-group)
+ "Kill process PROCESS. May be process or name of one.
+See function interrupt-process for more details on usage."
+ (let ((process (CHECK-PROCESS-COERCE (if (default-object? process)
+ '()
+ process)))
+ (group? (not (either-default? current-group))))
+ (kill-process process group?)
+ process))
+
+(DEFUN (el:quit-process #!optional process current-group)
+ "Send QUIT signal to process PROCESS. May be process or name of one.
+See function interrupt-process for more details on usage."
+ (let ((process (CHECK-PROCESS-COERCE (if (default-object? process)
+ '()
+ process)))
+ (group? (not (either-default? current-group))))
+ (quit-process process group?)
+ process))
+
+(DEFUN (el:stop-process #!optional process current-group)
+ "Stop process PROCESS. May be process or name of one.
+See function interrupt-process for more details on usage."
+ (let ((process (CHECK-PROCESS-COERCE (if (default-object? process)
+ '()
+ process)))
+ (group? (not (either-default? current-group))))
+ (stop-process process group?)
+ process))
+
+(DEFUN (el:continue-process #!optional process current-group)
+ "Continue process PROCESS. May be process or name of one.
+See function interrupt-process for more details on usage."
+ (let ((process (CHECK-PROCESS-COERCE (if (default-object? process)
+ '()
+ process)))
+ (group? (not (either-default? current-group))))
+ (continue-process process group?)
+ process))
+
+(DEFUN (el:process-send-eof #!optional process)
+ "Make PROCESS see end-of-file in its input.
+Eof comes after any text already sent to it.
+nil or no arg means current buffer's process."
+ (let ((process (CHECK-PROCESS-COERCE (if (default-object? process)
+ '()
+ process))))
+ (process-send-eof process)
+ process))
+\f
+(DEFVAR Qdelete-exited-processes
+ unassigned
+ "*Non-nil means delete processes immediately when they exit.
+nil means don't delete them until `list-processes' is run.
+
+NOTE: This variable can only be a boolean in Edwin."
+ (boolean-getter (ref-variable-object delete-exited-processes))
+ (boolean-setter (ref-variable-object delete-exited-processes)))
+
+(DEFVAR Qprocess-connection-type
+ unassigned
+ "Control type of device used to communicate with subprocesses.
+Values are nil to use a pipe, t for a pty (or pipe if ptys not supported).
+Value takes effect when `start-process' is called.
+
+NOTE: This variable can only be a boolean in Edwin."
+ (boolean-getter (ref-variable-object process-connection-type))
+ (boolean-setter (ref-variable-object process-connection-type)))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+String search routines for GNU Emacs. |#
+
+(declare (usual-integrations))
+\f
+(define Qsearch-failed (%intern "search-failed" initial-obarray))
+(%put! Qsearch-failed Qerror-conditions (list Qsearch-failed Qerror))
+(%put! Qsearch-failed Qerror-message "Search failed")
+
+(define Qinvalid-regexp (%intern "invalid-regexp" initial-obarray))
+(%put! Qinvalid-regexp Qerror-conditions (list Qinvalid-regexp Qerror))
+(%put! Qinvalid-regexp Qerror-message "Invalid regexp")
+
+(DEFUN (el:looking-at string)
+ "t if text after point matches regular expression PAT."
+ ;; This is just an expanded, simplified re-match-forward.
+ (let ((buffer (%current-buffer))
+ (string (CHECK-STRING string)))
+ (bind-condition-handler
+ (list condition-type:re-compile-pattern)
+ (lambda (condition)
+ (error:%signal Qinvalid-regexp
+ (list (access-condition condition 'MESSAGE))))
+ (lambda ()
+ (if (re-match-forward
+ string
+ (buffer-point buffer) (buffer-end buffer)
+ (not (null? (%symbol-value Qcase-fold-search))))
+ Qt
+ '())))))
+
+(DEFUN (el:string-match regexp string #!optional start)
+ "Return index of start of first match for REGEXP in STRING, or nil.
+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))))))))
+ (bind-condition-handler
+ (list condition-type:re-compile-pattern)
+ (lambda (condition)
+ (error:%signal Qinvalid-regexp
+ (list (access-condition condition 'MESSAGE))))
+ (lambda ()
+ (if (re-match-substring-forward
+ (re-compile-pattern regexp fold-case?)
+ fold-case? (el:syntax-table)
+ string start length)
+ Qt
+ '()))))))
+
+(DEFUN (el:skip-chars-forward string #!optional lim)
+ "Move point forward, stopping before a char not in CHARS, or at position LIM.
+CHARS is like the inside of a [...] in a regular expression
+except that ] is never special and \\ quotes ^, - or \\.
+Thus, with arg \"a-zA-Z\", this skips letters stopping before first nonletter.
+With arg \"^a-zA-Z\", skips nonletters stopping before first letter."
+ (let ((buffer (%current-buffer))
+ (string (CHECK-STRING string)))
+ (let ((limit (if (either-default? lim)
+ (buffer-end buffer)
+ (let ((min (buffer-start buffer))
+ (max (buffer-end buffer))
+ (lim (CHECK-MARKER-COERCE-INT lim buffer)))
+ (cond ((mark< lim min) min)
+ ((mark> lim max) max)
+ (else lim))))))
+ (bind-condition-handler
+ (list condition-type:re-compile-pattern)
+ (lambda (condition)
+ (error:%signal Qinvalid-regexp
+ (list (access-condition condition 'MESSAGE))))
+ (lambda ()
+ (set-buffer-point! buffer
+ (skip-chars-forward string
+ (buffer-point buffer)
+ limit 'LIMIT)))))))
+
+(DEFUN (el:skip-chars-backward string #!optional lim)
+ "Move point backward, stopping after a char not in CHARS, or at position LIM.
+See skip-chars-forward for details."
+ (let ((buffer (%current-buffer))
+ (string (CHECK-STRING string)))
+ (let ((limit (if (either-default? lim)
+ (buffer-start buffer)
+ (let ((min (buffer-start buffer))
+ (max (buffer-end buffer))
+ (lim (CHECK-MARKER-COERCE-INT lim buffer)))
+ (cond ((mark< lim min) min)
+ ((mark> lim max) max)
+ (else lim))))))
+ (bind-condition-handler
+ (list condition-type:re-compile-pattern)
+ (lambda (condition)
+ (error:%signal Qinvalid-regexp
+ (list (access-condition condition 'MESSAGE))))
+ (lambda ()
+ (set-buffer-point! buffer
+ (skip-chars-backward string
+ (buffer-point buffer) limit
+ 'LIMIT)))))))
+
+(DEFUN (el:search-backward string #!optional bound noerror count)
+ "Search backward from point for STRING.
+Set point to the beginning of the occurrence found, and return t.
+An optional second argument bounds the search; it is a buffer position.
+The match found must not extend before that position.
+Optional third argument, if t, means if fail just return nil (no error).
+ If not nil and not t, position at limit of search and return nil.
+Optional fourth argument is repeat count--search for successive occurrences."
+ (interactive "sSearch backward: ")
+ (let ((buffer (%current-buffer))
+ (string (CHECK-STRING string)))
+ (let ((bound (if (either-default? bound)
+ (buffer-start buffer)
+ (let ((min (buffer-start buffer))
+ (max (buffer-point buffer))
+ (bnd (CHECK-MARKER-COERCE-INT bound buffer)))
+ (cond ((mark< bnd min) min)
+ ((mark> bnd max)
+ (error:%signal Qerror (list "Invalid search bound (wrong side of point)")))
+ (else bnd)))))
+ (noerror (if (default-object? noerror) '() noerror)))
+ (let loop ((count (if (either-default? count)
+ 1
+ (CHECK-NUMBER count)))
+ (point (buffer-point buffer)))
+ (let ((new-point (search-backward
+ string point bound
+ (not (null? (%symbol-value Qcase-fold-search))))))
+ (cond ((and (not new-point) (null? noerror))
+ (error:%signal Qsearch-failed (list string)))
+ ((and (not new-point) (eq? noerror Qt))
+ '())
+ ((not new-point)
+ (set-buffer-point! buffer bound)
+ '())
+ ((> count 1)
+ (loop (-1+ count) new-point))
+ (else
+ (set-buffer-point! buffer new-point)
+ Qt)))))))
+
+(DEFUN (el:search-forward string #!optional bound noerror count)
+ "Search forward from point for STRING.
+Set point to the end of the occurrence found, and return t.
+An optional second argument bounds the search; it is a buffer position.
+The match found must not extend after that position.
+Optional third argument, if t, means if fail just return nil (no error).
+ If not nil and not t, move to limit of search and return nil.
+Optional fourth argument is repeat count--search for successive occurrences."
+ (interactive "sSearch: ")
+ (let ((buffer (%current-buffer))
+ (string (CHECK-STRING string)))
+ (let ((bound (if (either-default? bound)
+ (buffer-end buffer)
+ (let ((min (buffer-point buffer))
+ (max (buffer-end buffer))
+ (bnd (CHECK-MARKER-COERCE-INT bound buffer)))
+ (cond ((mark< bnd min)
+ (error:%signal Qerror (list "Invalid search bound (wrong side of point)")))
+ ((mark> bnd max) max)
+ (else bnd)))))
+ (noerror (if (default-object? noerror) '() noerror)))
+ (let loop ((count (if (either-default? count)
+ 1
+ (CHECK-NUMBER count)))
+ (point (buffer-point buffer)))
+ (let ((new-point (search-forward
+ string point bound
+ (not (null? (%symbol-value Qcase-fold-search))))))
+ (cond ((and (not new-point) (null? noerror))
+ (error:%signal Qsearch-failed (list string)))
+ ((and (not new-point) (eq? noerror Qt))
+ '())
+ ((not new-point)
+ (set-buffer-point! buffer bound)
+ '())
+ ((> count 1)
+ (loop (-1+ count) new-point))
+ (else
+ (set-buffer-point! buffer new-point)
+ Qt)))))))
+
+(DEFUN (el:word-search-backward string #!optional bound noerror count)
+ "Search backward from point for STRING, ignoring differences in punctuation.
+Set point to the beginning of the occurrence found, and return t.
+An optional second argument bounds the search; it is a buffer position.
+The match found must not extend before that position.
+Optional third argument, if t, means if fail just return nil (no error).
+ If not nil and not t, move to limit of search and return nil.
+Optional fourth argument is repeat count--search for successive occurrences."
+ (interactive "sWord search backward: ")
+ (el:re-search-backward
+ (string->wordified-regexp (CHECK-STRING string))
+ (if (default-object? bound) '() bound)
+ (if (default-object? noerror) '() noerror)
+ (if (default-object? count) '() count)))
+
+(DEFUN (el:word-search-forward string #!optional bound noerror count)
+ "Search forward from point for STRING, ignoring differences in punctuation.
+Set point to the end of the occurrence found, and return t.
+An optional second argument bounds the search; it is a buffer position.
+The match found must not extend after that position.
+Optional third argument, if t, means if fail just return nil (no error).
+ If not nil and not t, move to limit of search and return nil.
+Optional fourth argument is repeat count--search for successive occurrences."
+ (interactive "sWord search: ")
+ (el:re-search-forward
+ (string->wordified-regexp (CHECK-STRING string))
+ (if (default-object? bound) '() bound)
+ (if (default-object? noerror) '() noerror)
+ (if (default-object? count) '() count)))
+
+(DEFUN (el:re-search-backward string #!optional bound noerror count)
+ "Search backward from point for match for regular expression REGEXP.
+Set point to the beginning of the match, and return t.
+The match found is the one starting last in the buffer
+and yet ending before the place the origin of the search.
+An optional second argument bounds the search; it is a buffer position.
+The match found must start at or after that position.
+Optional third argument, if t, means if fail just return nil (no error).
+ If not nil and not t, move to limit of search and return nil.
+Optional fourth argument is repeat count--search for successive occurrences.
+See also the functions match-beginning and match-end and replace-match."
+ (interactive "sRE search backward: ")
+ (let ((buffer (%current-buffer))
+ (string (CHECK-STRING string)))
+ (let ((bound (if (either-default? bound)
+ (buffer-start buffer)
+ (let ((min (buffer-start buffer))
+ (max (buffer-point buffer))
+ (bnd (CHECK-MARKER-COERCE-INT bound buffer)))
+ (cond ((mark< bnd min) min)
+ ((mark> bnd max)
+ (error:%signal Qerror (list "Invalid search bound (wrong side of point)")))
+ (else bnd)))))
+ (noerror (if (default-object? noerror) '() noerror)))
+ (bind-condition-handler
+ (list condition-type:re-compile-pattern)
+ (lambda (condition)
+ (error:%signal Qinvalid-regexp
+ (list (access-condition condition 'MESSAGE))))
+ (lambda ()
+ (let loop ((count (if (either-default? count)
+ 1
+ (CHECK-NUMBER count)))
+ (point (buffer-point buffer)))
+ (let ((new-point
+ (re-search-backward
+ string point bound
+ (not (null? (%symbol-value Qcase-fold-search))))))
+ (cond ((and (not new-point) (null? noerror))
+ (error:%signal Qsearch-failed (list string)))
+ ((and (not new-point) (eq? noerror Qt))
+ '())
+ ((not new-point)
+ (set-buffer-point! buffer bound)
+ '())
+ ((> count 1)
+ (loop (-1+ count) new-point))
+ (else
+ (set-buffer-point! buffer new-point)
+ Qt)))))))))
+
+(DEFUN (el:re-search-forward string #!optional bound noerror count)
+ "Search forward from point for regular expression REGEXP.
+Set point to the end of the occurrence found, and return t.
+An optional second argument bounds the search; it is a buffer position.
+The match found must not extend after that position.
+Optional third argument, if t, means if fail just return nil (no error).
+ If not nil and not t, move to limit of search and return nil.
+Optional fourth argument is repeat count--search for successive occurrences.
+See also the functions match-beginning and match-end and replace-match."
+ (interactive "sRE search: ")
+ (let ((buffer (%current-buffer))
+ (string (CHECK-STRING string)))
+ (let ((bound (if (either-default? bound)
+ (buffer-end buffer)
+ (let ((min (buffer-point buffer))
+ (max (buffer-end buffer))
+ (bnd (CHECK-MARKER-COERCE-INT bound buffer)))
+ (cond ((mark< bnd min)
+ (error:%signal Qerror (list "Invalid search bound (wrong side of point)")))
+ ((mark> bnd max) max)
+ (else bnd)))))
+ (noerror (if (default-object? noerror) '() noerror)))
+ (bind-condition-handler
+ (list condition-type:re-compile-pattern)
+ (lambda (condition)
+ (error:%signal Qinvalid-regexp
+ (list (access-condition condition 'MESSAGE))))
+ (lambda ()
+ (let loop ((count (if (either-default? count)
+ 1
+ (CHECK-NUMBER count)))
+ (point (buffer-point buffer)))
+ (let ((new-point
+ (re-search-forward
+ string point bound
+ (not (null? (%symbol-value Qcase-fold-search))))))
+ (cond ((and (not new-point) (null? noerror))
+ (error:%signal Qsearch-failed (list string)))
+ ((and (not new-point) (eq? noerror Qt))
+ '())
+ ((not new-point)
+ (set-buffer-point! buffer bound)
+ '())
+ ((> count 1)
+ (loop (-1+ count) new-point))
+ (else
+ (set-buffer-point! buffer new-point)
+ Qt)))))))))
+
+(DEFUN (el:replace-match string #!optional fixedcase literal)
+ "Replace text matched by last search with NEWTEXT.
+If second arg FIXEDCASE is non-nil, do not alter case of replacement text.
+Otherwise convert to all caps or cap initials, like replaced text.
+If third arg LITERAL is non-nil, insert NEWTEXT literally.
+Otherwise treat \\ as special:
+ \\& in NEWTEXT means substitute original matched text,
+ \\N means substitute match for \\(...\\) number N,
+ \\\\ means insert one \\.
+Leaves point at end of replacement text."
+ (let ((string (CHECK-STRING string))
+ (fixedcase? (not (either-default? fixedcase)))
+ (literal? (not (either-default? literal))))
+ (let ((point (re-match-start 0)))
+ (%fixup-window-point-movement
+ (mark-buffer point) point
+ (lambda ()
+ (replace-match string fixedcase? literal?))))))
+
+(DEFUN (el:match-beginning num)
+ "Return the character number of start of text matched by last search.
+ARG, a number, specifies which parenthesized expression in the last regexp.
+ Value is nil if ARGth pair didn't match, or there were less than ARG pairs.
+Zero means the entire text matched by the whole regexp or whole string."
+ (let* ((num (let ((num (CHECK-NUMBER num)))
+ (if (<= 0 num 9)
+ num
+ (error:%signal Qargs-out-of-range
+ (list num 10)))))
+ (index (re-match-start-index num))
+ (group (object-unhash match-group)))
+ (if index
+ (if group
+ (1+ index)
+ index)
+ '())))
+
+(DEFUN (el:match-end num)
+ "Return the character number of end of text matched by last search.
+ARG, a number, specifies which parenthesized expression in the last regexp.
+ Value is nil if ARGth pair didn't match, or there were less than ARG pairs.
+Zero means the entire text matched by the whole regexp or whole string."
+ (let* ((num (let ((num (CHECK-NUMBER num)))
+ (if (<= 0 num 9)
+ num
+ (error:%signal Qargs-out-of-range
+ (list num 10)))))
+ (index (re-match-end-index num))
+ (group (object-unhash match-group)))
+ (if index
+ (if group
+ (1+ index)
+ index)
+ '())))
+
+(DEFUN (el:match-data)
+ "Return list containing all info on what the last search matched.
+Element 2N is (match-beginning N); element 2N + 1 is (match-end N).
+All the elements are normally markers, or nil if the Nth pair didn't match.
+0 is also possible, when matching was done with `string-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))))
+ (let loop ((i 0) (list '()))
+ (if (or (= i 10)
+ (not (re-match-start-index i)))
+ (reverse! list)
+ (loop (1+ i)
+ (cons (->data (re-match-end-index i))
+ (cons (->data (re-match-start-index i))
+ list)))))))
+
+(DEFUN (el:store-match-data list)
+ "Set internal data on last search match from elements of LIST.
+LIST should have been created by calling match-data previously."
+ (vector-fill! registers false)
+ (let loop ((i 0)
+ (list (CHECK-LIST list)))
+ (if (and (pair? list)
+ (pair? (cdr list)))
+ (let ((start (car list))
+ (end (car (cdr list))))
+ (if (mark? start)
+ (begin
+ (vector-set! registers i (mark-index start))
+ (vector-set! registers (+ i 10) (mark-index end)))
+ (begin
+ (vector-set! registers i (CHECK-NUMBER start))
+ (vector-set! registers i (CHECK-NUMBER end))))
+ (loop (1+ i) (cdr (cdr list))))
+ '())))
+
+(DEFUN (el:regexp-quote str)
+ "Return a regexp string which matches exactly STRING and nothing else."
+ (re-quote-string (CHECK-STRING str)))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+GNU Emacs routines to deal with syntax tables; also word and list parsing. |#
+
+(declare (usual-integrations))
+\f
+(DEFVAR Qparse-sexp-ignore-comments
+ '()
+ "Non-nil means forward-sexp, etc., should treat comments as whitespace.
+Non-nil works only when the comment terminator is something like *\/,
+and appears only when it ends a comment.
+If comments are terminated by newlines,
+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))
+
+(define (guarantee-syntax-table table)
+ (if (syntax-table? table)
+ table
+ (wrong-type-argument el:syntax-table-p table)))
+
+(DEFUN (el:syntax-table)
+ "Return the current syntax table.
+This is the one specified by the current buffer."
+ (variable-local-value (%current-buffer) (ref-variable-object syntax-table)))
+
+(DEFUN (el:standard-syntax-table)
+ "Return the standard syntax table.
+This is the one used for new buffers."
+ standard-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)))))
+
+(DEFUN (el:set-syntax-table table)
+ "Select a new syntax table for the current buffer.
+One argument, a syntax table."
+ (set-variable-local-value!
+ (%current-buffer)
+ (ref-variable-object syntax-table)
+ (guarantee-syntax-table table)))
+
+(DEFUN (el:char-syntax ch)
+ "Return the syntax code of CHAR, described by a character.
+For example, if CHAR is a word constituent, ?w is returned.
+The characters that correspond to various syntax codes
+are listed in the documentation of modify-syntax-entry."
+ (char->syntax-code (ref-variable syntax-table (%current-buffer))
+ ch))
+
+(DEFUN (el:modify-syntax-entry c newentry #!optional syntax-table)
+ "Set syntax for character CHAR according to string S.
+The syntax is changed only for table TABLE, which defaults to
+ the current buffer's syntax table.
+The first character of S should be one of the following:
+ Space whitespace syntax. w word constituent.
+ _ symbol constituent. . punctuation.
+ ( open-parenthesis. ) close-parenthesis.
+ \" string quote. \\ character-quote.
+ $ paired delimiter. ' expression prefix operator.
+ < comment starter. > comment ender.
+Only single-character comment start and end sequences are represented thus.
+Two-character sequences are represented as described below.
+The second character of S is the matching parenthesis,
+ used only if the first character is ( or ).
+Any additional characters are flags.
+Defined flags are the characters 1, 2, 3 and 4.
+ 1 means C is the start of a two-char comment start sequence.
+ 2 means C is the second character of such a sequence.
+ 3 means C is the start of a two-char comment end sequence.
+ 4 means C is the second character of such a sequence."
+ (interactive "cSet syntax for character: \nsSet syntax for %s to: ")
+ (let ((syntax-table (if (default-object? syntax-table)
+ (ref-variable syntax-table (%current-buffer))
+ (guarantee-syntax-table syntax-table)))
+ (char (CHECK-CHAR c))
+ (str (CHECK-STRING newentry)))
+ (modify-syntax-entry! syntax-table char str)))
+
+(DEFUN (el:describe-syntax)
+ "Describe the syntax specifications in the syntax table.
+The descriptions are inserted in a buffer, which is selected so you can see it."
+ (interactive "")
+ ((ref-command describe-syntax)))
+
+(DEFUN (el:forward-word count)
+ "Move point forward ARG words (backward if ARG is negative).
+Normally returns t.
+If an edge of the buffer is reached, point is left there
+and nil is returned."
+ (interactive "p")
+ ((ref-command forward-word) (CHECK-NUMBER count)))
+
+(define (scan-lists-or-sexps from count depth sexp?)
+ (let ((buffer (%current-buffer)))
+ (let ((group (buffer-group buffer))
+ (syntax-entries (syntax-table/entries
+ (ref-variable syntax-table buffer))))
+ (let loop ((count count)
+ (depth depth)
+ (start from))
+ (cond ((not start) false)
+ ((zero? count) (make-mark group start))
+ ((negative? count)
+ (loop (1+ count)
+ 0
+ ((ucode-primitive scan-list-backward)
+ syntax-entries
+ group
+ start
+ (mark-index (buffer-start buffer))
+ depth
+ sexp?
+ false)))
+ (else
+ (loop (-1+ count)
+ 0
+ ((ucode-primitive scan-list-forward)
+ syntax-entries
+ group
+ start
+ (mark-index (buffer-end buffer))
+ depth
+ sexp?
+ (not (null? (%symbol-value
+ Qparse-sexp-ignore-comments)))))))))))
+
+(DEFUN (el:scan-lists from count depth)
+ "Scan from character number FROM by COUNT lists.
+Returns the character number of the position thus found.
+
+If DEPTH is nonzero, paren depth begins counting from that value,
+only places where the depth in parentheses becomes zero
+are candidates for stopping; COUNT such places are counted.
+Thus, a positive value for DEPTH means go out levels.
+
+Comments are ignored if parse-sexp-ignore-comments is non-nil.
+
+If the beginning or end of (the visible part of) the buffer is reached
+and the depth is wrong, an error is signaled.
+If the depth is right but the count is not used up, nil is returned."
+ (let ((mark (scan-lists-or-sexps
+ (mark-index (CHECK-MARKER-COERCE-INT from (%current-buffer)))
+ (CHECK-NUMBER count)
+ (CHECK-NUMBER depth)
+ false)))
+ (if mark
+ (%mark->number mark)
+ '())))
+
+(DEFUN (el:scan-sexps from count)
+ "Scan from character number FROM by COUNT balanced expressions.
+Returns the character number of the position thus found.
+
+Comments are ignored if parse-sexp-ignore-comments is non-nil.
+
+If the beginning or end of (the visible part of) the buffer is reached
+in the middle of a parenthetical grouping, an error is signaled.
+If the beginning or end is reached between groupings but before count is used up,
+nil is returned."
+ (let ((mark (scan-lists-or-sexps
+ (mark-index (CHECK-MARKER-COERCE-INT from (%current-buffer)))
+ (CHECK-NUMBER count)
+ 0
+ true)))
+ (if mark
+ (%mark->number mark)
+ '())))
+
+(DEFUN (el:backward-prefix-chars)
+ "Move point backward over any number of chars with syntax \"prefix\"."
+ (backward-prefix-chars (buffer-point (%current-buffer))))
+
+(DEFUN (el:parse-partial-sexpr from to
+ #!optional targetdepth stopbefore oldstate)
+ "Parse Lisp syntax starting at FROM until TO; return status of parse at TO.
+Parsing stops at TO or when certain criteria are met;
+ point is set to where parsing stops.
+If fifth arg STATE is omitted or nil,
+ parsing assumes that FROM is the beginning of a function.
+Value is a list of seven elements describing final state of parsing:
+ 1. depth in parens.
+ 2. character address of start of innermost containing list; nil if none.
+ 3. character address of start of last complete sexp terminated.
+ 4. non-nil if inside a string.
+ (it is the character that will terminate the string.)
+ 5. t if inside a comment.
+ 6. t if following a quote character.
+ 7. the minimum paren-depth encountered during this scan.
+If third arg TARGETDEPTH is non-nil, parsing stops if the depth
+in parentheses becomes equal to TARGETDEPTH.
+Fourth arg STOPBEFORE non-nil means stop when come to
+ any character that starts a sexp.
+Fifth arg STATE is a seven-list like what this function returns.
+It is used to initialize the state of the parse."
+ (let ((from (CHECK-MARKER-COERCE-INT from (%current-buffer)))
+ (to (CHECK-MARKER-COERCE-INT to (%current-buffer))))
+ (cond ((and (either-default? oldstate)
+ (either-default? stopbefore)
+ (either-default? targetdepth))
+ (parse-partial-sexp from to))
+ ((and (either-default? oldstate)
+ (either-default? stopbefore))
+ (parse-partial-sexp from to
+ (CHECK-NUMBER targetdepth)))
+ ((either-default? oldstate)
+ (parse-partial-sexp from to
+ (and (not (null? targetdepth))
+ (CHECK-NUMBER targetdepth))
+ true))
+ ((vector? oldstate) ; No parse-state? predicate?
+ (parse-partial-sexp from to
+ (and (not (null? targetdepth))
+ (CHECK-NUMBER targetdepth))
+ (not (either-default? stopbefore))
+ oldstate))
+ (else
+ (error "Edwin doesn't support Emacs-style parse states.")))))
\ No newline at end of file
--- /dev/null
+#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*-
+
+$Id: $
+
+Copyright (c) 1993 Matthew Birkholz, All Rights Reserved
+
+Window creation, deletion and examination for GNU Emacs. |#
+
+(declare (usual-integrations))
+\f
+(DEFUN (el:windowp obj)
+ "Returns t if OBJ is a window."
+ (if (window? obj)
+ Qt '()))
+
+(DEFUN (el:selected-window)
+ "Return the window that the cursor now appears in and commands apply to."
+ (current-window))
+
+(DEFUN (el:minibuffer-window)
+ "Return the window used for minibuffers."
+ (typein-window))
+
+(DEFUN (el:pos-visible-in-window-p #!optional pos window)
+ "Return t if position POS is currently on the screen in WINDOW.
+Returns nil if that position is scrolled vertically out of view.
+POS defaults to point; WINDOW, to the selected window."
+ (let* ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window)))
+ (buffer (window-buffer window))
+ (cursor (if (either-default? pos)
+ (buffer-point buffer)
+ (CHECK-MARKER-COERCE-INT pos buffer))))
+ (if (window-mark-visible? window cursor)
+ Qt '())))
+
+(DEFUN (el:window-buffer #!optional window)
+ "Return the buffer that WINDOW is displaying."
+ (let ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window))))
+ (window-buffer window)))
+
+(DEFUN (el:window-height #!optional window)
+ "Return the number of lines in WINDOW (including its mode line)."
+ (let ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window))))
+ (1+ (window-y-size window))))
+
+(DEFUN (el:window-width #!optional window)
+ "Return the number of columns in WINDOW."
+ (let ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window))))
+ (window-x-size window)))
+
+(DEFUN (el:window-hscroll #!optional window)
+ "Return the number of columns by which WINDOW is scrolled from left margin."
+ window
+ 0)
+
+#|(DEFUN (el:set-window-hscroll window ncol)
+ "Set number of columns WINDOW is scrolled from left margin to NCOL.
+NCOL should be zero or positive."
+ (let ((ncol (max (CHECK-NUMBER ncol) 0))
+ (win (CHECK-WINDOW window)))
+
+ ncol))|#
+
+(DEFUN (el:window-edges #!optional window)
+ "Return a list of the edge coordinates of WINDOW.
+\(LEFT TOP RIGHT BOTTOM), all relative to 0, 0 at top left corner of screen.
+RIGHT is one more than the rightmost column used by WINDOW,
+and BOTTOM is one more than the bottommost row used by WINDOW
+ and its mode-line."
+ (let* ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window))))
+ (%window-edges
+ window
+ (lambda (x-start y-start x-end y-end)
+ (list x-start y-start x-end y-end)))))
+
+(define (%window-edges window receiver)
+
+ (define (%window-start? superior superior-x superior-y)
+ (let loop ((inferiors (window-inferiors superior)))
+ (if (not (pair? inferiors))
+ false
+ (let* ((inferior (car inferiors))
+ (this-window (inferior-window inferior)))
+ (inferior-start
+ inferior
+ (lambda (x-start y-start)
+ (inferior-size
+ inferior
+ (lambda (x-size y-size)
+ (if (eq? window this-window)
+ (receiver
+ (+ superior-x x-start)
+ (+ superior-y y-start)
+ (+ superior-x x-start x-size)
+ (+ superior-y y-start y-size))
+ (or (%window-start? this-window
+ (+ superior-x x-start)
+ (+ superior-y y-start))
+ (loop (cdr inferiors))))))))))))
+
+ (or (%window-start? (window-root-window window) 0 0)
+ (error "%window-edges: window not found")))
+
+(DEFUN (el:window-point #!optional window)
+ "Return current value of point in WINDOW.
+For a nonselected window, this is the value point would have
+if that window were selected.
+
+Note that, when WINDOW is the selected window and its buffer
+is also currently selected, the value returned is the same as (point).
+It would be more strictly correct to return the `top-level' value
+of point, outside of any save-excursion forms.
+But that is hard to define."
+ (let ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window))))
+ (%mark->number (window-point window))))
+
+(DEFUN (el:window-start #!optional window)
+ "Return position at which display currently starts in WINDOW."
+ (let ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window))))
+ (%mark->number (window-start-mark window))))
+
+(DEFUN (el:set-window-point window pos)
+ "Make point value in WINDOW be at position POS in WINDOW's buffer."
+ (let* ((window (CHECK-WINDOW window))
+ (mark (CHECK-MARKER-COERCE-INT pos (window-buffer window))))
+ (set-window-point! window mark)
+ (%mark->number mark)))
+
+(DEFUN (el:set-window-start window pos #!optional noforce)
+ "Make display in WINDOW start at position POS in WINDOW's buffer.
+Optional third arg NOFORCE non-nil inhibits next redisplay
+from overriding motion of point in order to display at this exact start."
+ (let ((window (CHECK-WINDOW window))
+ (mark (CHECK-MARKER-COERCE-INT pos (window-buffer window)))
+ (force? (either-default? noforce)))
+ (set-window-start-mark! window mark force?)
+ (%mark->number pos)))
+
+(DEFUN (el:delete-window #!optional window)
+ "Remove WINDOW from the display. Default is selected window."
+ (interactive "")
+ (let ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window))))
+ (if (or (window-has-no-neighbors? window)
+ (typein-window? window))
+ (error:%signal
+ Qerror
+ (list "Attempt to delete minibuffer or sole ordinary window"))
+ (window-delete! window)))
+ '())
+
+(DEFUN (el:next-window #!optional window mini)
+ "Return next window after WINDOW in canonical ordering of windows.
+Optional second arg MINIBUF t means count the minibuffer window
+even if not active. If MINIBUF is neither t nor nil it means
+not to count the minibuffer even if it is active."
+ (let ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window)))
+ (inactive-mini? (and (not (default-object? mini))
+ (eq? mini Qt)))
+ (no-mini? (and (not (either-default? mini))
+ (not (eq? mini Qt)))))
+ (let ((next (window1+ window)))
+ (if (and (eq? next (screen-window0 (window-screen window)))
+ (not no-mini?)
+ (or inactive-mini? (within-typein-edit?)))
+ (screen-typein-window (window-screen window))
+ next))))
+
+(DEFUN (el:previous-window #!optional window)
+ "Return previous window before WINDOW in canonical ordering of windows."
+ (let ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window))))
+ (if (and (eq? window (screen-window0 (window-screen window)))
+ (within-typein-edit?))
+ (screen-typein-window (window-screen window))
+ (window-1+ window))))
+
+(DEFUN (el:other-window n)
+ "Select the ARG'th different window."
+ (interactive "p")
+ (select-window (other-window n)))
+
+(DEFUN (el:get-lru-window)
+ "Return the window least recently selected or used for display."
+ (lru-window))
+
+(DEFUN (el:get-largest-window)
+ "Return the largest window in area."
+ (largest-window))
+
+(DEFUN (el:get-buffer-window buffer)
+ "Return a window currently displaying BUFFER, or nil if none."
+ (let ((buffer (el:get-buffer buffer)))
+ (or (and buffer (get-buffer-window buffer))
+ '())))
+
+(DEFUN (el:delete-other-windows #!optional w)
+ "Make WINDOW (or the selected window) fill the screen."
+ (interactive "")
+ (let ((window (if (either-default? w)
+ (current-window)
+ (CHECK-WINDOW w))))
+ (delete-other-windows window))
+ '())
+
+(DEFUN (el:delete-windows-on buffer)
+ "Delete all windows showing BUFFER."
+ (interactive "bDelete windows on (buffer): ")
+ (let ((buffer (el:get-buffer buffer)))
+ (let loop ((windows (if buffer (buffer-windows buffer) '())))
+ (if (pair? windows)
+ (begin
+ (window-delete! (car windows))
+ (loop (cdr windows))))))
+ '())
+
+(DEFUN (el:replace-buffer-in-windows buffer)
+ "Replace BUFFER with some other buffer in all windows showing it."
+ (interactive "bReplace buffer in windows: ")
+ (let ((buffer (CHECK-BUFFER (el:get-buffer buffer))))
+ (let loop ((windows (buffer-windows buffer)))
+ (if (pair? windows)
+ (let ((window (car windows)))
+ (set-window-buffer! window (other-buffer (window-buffer window)))
+ (loop (cdr windows))))))
+ '())
+
+(DEFUN (el:set-window-buffer window buffer)
+ "Make WINDOW display BUFFER as its contents.
+BUFFER can be a buffer or buffer name."
+ (let ((window (CHECK-WINDOW window))
+ (buffer (CHECK-BUFFER (el:get-buffer buffer))))
+ (if (not (buffer-alive? buffer))
+ (error:%signal Qerror (list "Attempt to display deleted buffer")))
+ (set-window-buffer! window buffer)
+ (if (current-window? window)
+ (%set-current-buffer! buffer)))
+ '())
+
+(DEFUN (el:select-window window)
+ "Select WINDOW. Most editing will apply to WINDOW's buffer.
+The main editor command loop selects the buffer of the selected window
+before each command."
+ (let ((window (CHECK-WINDOW window)))
+ (cond ((not (window-buffer window))
+ (el:signal Qerror (list "Trying to select window with no buffer")))
+ ((current-window? window) window)
+ (else
+ (select-window window)
+ (%set-current-buffer! (window-buffer window))
+ window))))
+
+(DEFUN (el:display-buffer buffer #!optional notthiswindow)
+ "Make BUFFER appear in some window but don't select it.
+BUFFER can be a buffer or a buffer name.
+If BUFFER is shown already in some window, just uses that one,
+unless the window is the selected window and NOTTHISWINDOW is non-nil.
+Returns the window displaying BUFFER."
+ (let ((buffer (CHECK-BUFFER (el:get-buffer buffer)))
+ (thiswindow-ok? (either-default? notthiswindow)))
+ (if (either-default? notthiswindow)
+ (pop-up-buffer buffer)
+ (pop-up-buffer buffer false true))))
+
+(DEFUN (el:split-window #!optional window chsize horflag)
+ "Split WINDOW, putting SIZE lines in the first of the pair.
+WINDOW defaults to selected one and SIZE to half its size.
+If optional third arg HOR-FLAG is non-nil, split side by side
+and put SIZE columns in the first of the pair."
+ (interactive "")
+ (let ((window (if (either-default? window)
+ (current-window)
+ (CHECK-WINDOW window)))
+ (horizontal? (not (either-default? horflag))))
+ (if (typein-window? window)
+ (el:signal Qerror (list "Attempt to split minibuffer window")))
+ (let ((chsize (if (either-default? chsize)
+ (/ (if horizontal?
+ (1+ (window-x-size window))
+ (window-y-size window))
+ 2)
+ (CHECK-NUMBER chsize))))
+ (let ((new (if horizontal?
+ (window-split-horizontally! window chsize)
+ (window-split-vertically! window chsize))))
+ (or new
+ (error:%signal Qargs-out-of-range
+ (list window
+ chsize
+ (if horizontal? Qt '()))))))))
+
+(DEFUN (el:enlarge-window n #!optional side)
+ "Make current window ARG lines bigger.
+From program, optional second arg non-nil means grow sideways ARG columns."
+ (interactive "p")
+ (let ((n (CHECK-NUMBER n))
+ (side? (not (either-default? side)))
+ (window (current-window)))
+ (if (not (zero? n))
+ (if side?
+ (if (window-has-horizontal-neighbor? window)
+ (window-grow-horizontally! (current-window) n)
+ (el:signal Qerror
+ (list "No other window to side of this one")))
+ (if (window-has-vertical-neighbor? window)
+ (window-grow-vertically! (current-window) n)
+ (el:signal Qerror
+ (list "No other window to side of this one"))))))
+ '())
+
+(DEFUN (el:shrink-window n #!optional side)
+ "Make current window ARG lines smaller.
+From program, optional second arg non-nil means shrink sideways ARG columns."
+ (interactive "p")
+ (let ((n (CHECK-NUMBER n))
+ (side? (not (either-default? side))))
+ (if side?
+ (window-grow-vertically! (current-window) (- n))
+ (window-grow-horizontally! (current-window) (- n))))
+ '())
+
+(DEFUN (el:scroll-up #!optional n)
+ "Scroll text of current window upward ARG lines; or near full screen if no ARG.
+When calling from a program, supply a number as argument or nil."
+ (interactive "P")
+ (let ((n (if (either-default? n)
+ false
+ (CHECK-NUMBER n)))
+ (window (current-window)))
+ (scroll-window window
+ (standard-scroll-window-argument window n 1)
+ (lambda () (el:signal Qend-of-buffer '()))))
+ '())
+
+(DEFUN (el:scroll-down #!optional n)
+ "Scroll text of current window downward ARG lines; or near full screen if no ARG.
+When calling from a program, supply a number as argument or nil."
+ (interactive "P")
+ (let ((n (if (either-default? n)
+ false
+ (CHECK-NUMBER n)))
+ (window (current-window)))
+ (scroll-window window
+ (standard-scroll-window-argument window n -1)
+ (lambda () (el:signal Qbeginning-of-buffer '()))))
+ '())
+
+#|(DEFUN (el:scroll-left arg)
+ "Scroll selected window display ARG columns left.
+Default for ARG is window width minus 2."
+ (interactive "P")
+
+ '())|#
+
+#|(DEFUN (el:scroll-right arg)
+ "Scroll selected window display ARG columns right.
+Default for ARG is window width minus 2."
+ (interactive "P")
+
+ '())|#
+
+(DEFUN (el:scroll-other-window #!optional n)
+ "Scroll text of next window upward ARG lines; or near full screen if no ARG.
+The next window is the one below the current one; or the one at the top
+if the current one is at the bottom.
+When calling from a program, supply a number as argument or nil."
+ (interactive "P")
+ ((ref-command scroll-other-window) n)
+ '())
+
+(DEFUN (el:recenter #!optional n)
+ "Center point in window and redisplay screen. With ARG, put point on line ARG.
+The desired position of point is always relative to the current window.
+Just C-u as prefix means put point in the center of the screen.
+No arg (i.e., it is nil) erases the entire screen and then
+redraws with point in the center."
+ (interactive "P")
+ ((ref-command recenter) n)
+ '())
+
+(DEFUN (el:move-to-window-line arg)
+ "Position point relative to window.
+With no argument, position at text at center of window.
+An argument specifies screen line; zero means top of window,
+negative means relative to bottom of window."
+ (interactive "P")
+ ((ref-command move-to-window-line) arg)
+ '())
+
+(DEFUN (el:set-window-configuration arg)
+ "Restore the configuration of Emacs' windows and buffers to
+the state specified by CONFIGURATION. CONFIGURATION must be a value
+returned by current-window-configuration -- see the documentation of that
+function for more information."
+ (guarantee-window-configuration arg 'EL:SET-WINDOW-CONFIGURATION)
+ (set-screen-window-configuration! (selected-screen) arg)
+ '())
+
+(DEFUN (el:current-window-configuration)
+ "Return an object representing Emacs' current window configuration,
+namely the number of windows, their sizes and current buffers, and for
+each displayed buffer, where display starts, and the positions of
+point and mark. An exception is made for point in (current-buffer) --
+its value is -not- saved."
+ (screen-window-configuration (selected-screen)))
+
+(DEFUN (el:save-window-excursion "e . args)
+ "Execute body, preserving window sizes and contents.
+Restores which buffer appears in which window, where display starts,
+as well as the current buffer.
+Does not restore the value of point in current buffer."
+ (%save-window-excursion
+ (lambda () (apply el:progn args))))
+
+(define (%save-window-excursion thunk)
+ (let ((screen (selected-screen)))
+ (let ((configuration-inside (screen-window-configuration screen))
+ (configuration-outside))
+ (unwind-protect
+ (lambda ()
+ (set! configuration-outside (screen-window-configuration screen))
+ (set-screen-window-configuration! screen configuration-inside)
+ unspecific)
+ thunk
+ (lambda ()
+ (set! configuration-inside (screen-window-configuration
+ screen))
+ (set-screen-window-configuration! screen configuration-outside)
+ unspecific)))))
+
+#|(DEFVAR Qminibuffer-prompt-width
+ unassigned
+ "Width of the prompt appearing at the start of the minibuffer window.
+The value is meaningless when the minibuffer is not visible.")|#
+
+(DEFVAR Qtemp-buffer-show-hook
+ '()
+ "Non-nil means call as function to display a help buffer.
+Used by with-output-to-temp-buffer.")
+
+(DEFVAR Qminibuffer-scroll-window
+ '()
+ "Non-nil means it is the window that C-M-v in minibuffer should scroll."
+ (lambda ()
+ (or (object-unhash *minibuffer-scroll-window*)
+ '()))
+ (lambda (value)
+ (if (not (null? value))
+ (set! *minibuffer-scroll-window* (object-hash value)))))
+
+;;; Existing Edwin variables.
+
+(DEFVAR Qpop-up-windows
+ unassigned
+ "*Non-nil means display-buffer should make new windows.
+
+NOTE: This variable can only be a boolean in Edwin."
+ (boolean-getter (ref-variable-object pop-up-windows))
+ (boolean-setter (ref-variable-object pop-up-windows)))
+
+(DEFVAR Qnext-screen-context-lines
+ unassigned ;(ref-variable next-screen-context-lines)
+ "*Number of lines of continuity when scrolling by screenfuls.
+
+NOTE: This variable can only be an exact nonnegative integer in Edwin.")
+
+(DEFVAR Qsplit-height-threshold
+ unassigned ;(ref-variable split-height-threshold)
+ "*display-buffer would prefer to split the largest window if this large.
+If there is only one window, it is split regardless of this value.
+
+NOTE: This variable can only be an exact nonnegative integer in Edwin.")
+
+(DEFVAR Qwindow-min-height
+ unassigned ;(ref-variable window-min-height)
+ "*Delete any window less than this tall (including its mode line).
+
+NOTE: This variable can only be an exact integer greater than 1 in Edwin.")
+
+(DEFVAR Qwindow-min-width
+ unassigned ;(ref-variable window-min-width)
+ "*Delete any window less than this wide.
+
+NOTE: This variable can only be an exact integer greater than 2 in Edwin.")
\ No newline at end of file
projects / mit-scheme.git / commitdiff