From: Matt Birkholz Date: Tue, 18 Jan 2011 18:17:10 +0000 (-0700) Subject: Original source from thesis project. X-Git-Tag: 20110609-ELisp~6 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fce83fae5a2d1ecfee669c77f856cc8ae0b0aea6;p=mit-scheme.git Original source from thesis project. This version implemented variable binding with dynamic-wind, which performed poorly. --- diff --git a/src/elisp/Buffers.scm b/src/elisp/Buffers.scm new file mode 100644 index 000000000..2b5d6a28c --- /dev/null +++ b/src/elisp/Buffers.scm @@ -0,0 +1,70 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/Macros.scm b/src/elisp/Macros.scm new file mode 100644 index 000000000..eb2e769e9 --- /dev/null +++ b/src/elisp/Macros.scm @@ -0,0 +1,105 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/Misc.scm b/src/elisp/Misc.scm new file mode 100644 index 000000000..f08a158b5 --- /dev/null +++ b/src/elisp/Misc.scm @@ -0,0 +1,341 @@ +#| -*- 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)) + +;;;; 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 \\=\\ 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 diff --git a/src/elisp/Reader.scm b/src/elisp/Reader.scm new file mode 100644 index 000000000..d206bd9ee --- /dev/null +++ b/src/elisp/Reader.scm @@ -0,0 +1,385 @@ +#| -*- 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)) + +(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)) + +;;;; 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 \. + (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)))) + +;;;; 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)))) + +;;;; 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)))) + +;;;; 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 diff --git a/src/elisp/Subrs.scm b/src/elisp/Subrs.scm new file mode 100644 index 000000000..96a70da85 --- /dev/null +++ b/src/elisp/Subrs.scm @@ -0,0 +1,55 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/Symbols.scm b/src/elisp/Symbols.scm new file mode 100644 index 000000000..53924a636 --- /dev/null +++ b/src/elisp/Symbols.scm @@ -0,0 +1,594 @@ +#| -*- 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)) + +(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))) + +;;;; 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)))) + +;;;; 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) + +;;;; 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)) + +;;;; 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 diff --git a/src/elisp/abbrev.scm b/src/elisp/abbrev.scm new file mode 100644 index 000000000..cb9e862bf --- /dev/null +++ b/src/elisp/abbrev.scm @@ -0,0 +1,207 @@ +#| -*- 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)) + +#| 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)) + '()) + +(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)))) + +#| 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." + )|# + +(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))))))) + '()) + +(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 diff --git a/src/elisp/alloc.scm b/src/elisp/alloc.scm new file mode 100644 index 000000000..878d917cb --- /dev/null +++ b/src/elisp/alloc.scm @@ -0,0 +1,159 @@ +#| -*- 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)) + +(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))) + +(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)) + +(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))) + +(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)) + +(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))) + +(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)))))) + +(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 diff --git a/src/elisp/buffer.scm b/src/elisp/buffer.scm new file mode 100644 index 000000000..ad9b348e7 --- /dev/null +++ b/src/elisp/buffer.scm @@ -0,0 +1,778 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/bytecode.scm b/src/elisp/bytecode.scm new file mode 100644 index 000000000..fa7dd402c --- /dev/null +++ b/src/elisp/bytecode.scm @@ -0,0 +1,833 @@ +#| -*- 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)) + +;;;; 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)))|#) + +;;;; 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 + +;;;; 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)) + +;;;; 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 diff --git a/src/elisp/callint.scm b/src/elisp/callint.scm new file mode 100644 index 000000000..7f9327404 --- /dev/null +++ b/src/elisp/callint.scm @@ -0,0 +1,372 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/callproc.scm b/src/elisp/callproc.scm new file mode 100644 index 000000000..080b98e1e --- /dev/null +++ b/src/elisp/callproc.scm @@ -0,0 +1,104 @@ +#| -*- 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 diff --git a/src/elisp/cmds.scm b/src/elisp/cmds.scm new file mode 100644 index 000000000..5e4ea581d --- /dev/null +++ b/src/elisp/cmds.scm @@ -0,0 +1,150 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/data.scm b/src/elisp/data.scm new file mode 100644 index 000000000..e9e00c018 --- /dev/null +++ b/src/elisp/data.scm @@ -0,0 +1,605 @@ +#| -*- 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)) + +;(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 diff --git a/src/elisp/dired.scm b/src/elisp/dired.scm new file mode 100644 index 000000000..8ad7de642 --- /dev/null +++ b/src/elisp/dired.scm @@ -0,0 +1,101 @@ +#| -*- 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.")|# + +#|(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)) + '()))) + +(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 diff --git a/src/elisp/editfns.scm b/src/elisp/editfns.scm new file mode 100644 index 000000000..49bd71e44 --- /dev/null +++ b/src/elisp/editfns.scm @@ -0,0 +1,650 @@ +#| -*- 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)) + +(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)))) + +(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))) + '()))) + +(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))) + +(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))) + '()) + +(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))))) + '()) + +(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))))))) + +(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)) + +(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: + ;; `'. + ;; + ;; 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 + ;; 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 "*" + ;; 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")))) + +(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 diff --git a/src/elisp/elisp.ldr b/src/elisp/elisp.ldr new file mode 100644 index 000000000..8dd239ec4 --- /dev/null +++ b/src/elisp/elisp.ldr @@ -0,0 +1,33 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (c) 1993 Matthew Birkholz, All Rights Reserved + +Not generated by CREF! |# + +(declare (usual-integrations)) + +(lambda (load key-alist) + (let ((sf-and-load + (lambda (files package #!optional syntax-table) + (fluid-let ((sf/default-syntax-table + (if (default-object? syntax-table) + syntax-table/system-internal + syntax-table))) + (sf-conditionally files)) + (for-each (lambda (file) (load file package)) + files)))) + (sf-and-load '("Buffers") '(ELISP BUFFERS)) + (sf-and-load '("Subrs") '(ELISP SUBRS)) + (sf-and-load '("Symbols") '(ELISP SYMBOLS)) + (sf-and-load '("Macros") '(ELISP SYNTAX-EXTENSIONS)) + (sf-and-load '("Reader") '(ELISP READER)) + (sf-and-load '("Misc" "lisp" "data" "eval" "fns" "lread" "buffer" + "editfns" "fileio" "alloc" "minibuf" "search" + "callint" "syntax" "cmds" "marker" "window" + "keymap" "print" "indent" "process" "dired" + "abbrev" "bytecode") + '(ELISP) + (environment-lookup (->environment '(ELISP)) + 'elisp-syntax-table)))) \ No newline at end of file diff --git a/src/elisp/elisp.pkg b/src/elisp/elisp.pkg new file mode 100644 index 000000000..4c7c58520 --- /dev/null +++ b/src/elisp/elisp.pkg @@ -0,0 +1,157 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (c) 1993 Matthew Birkholz, All Rights Reserved |# + +;;;; ELisp Packaging + +(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 diff --git a/src/elisp/elisp.sf b/src/elisp/elisp.sf new file mode 100644 index 000000000..04cc7a252 --- /dev/null +++ b/src/elisp/elisp.sf @@ -0,0 +1,54 @@ +#| -*-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")))) + +;;; 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 diff --git a/src/elisp/eval.scm b/src/elisp/eval.scm new file mode 100644 index 000000000..bc80cb8a8 --- /dev/null +++ b/src/elisp/eval.scm @@ -0,0 +1,779 @@ +#| -*- 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)) + +(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") + +(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)))))) + +;;;; 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)))) + +;;;; 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 diff --git a/src/elisp/fileio.scm b/src/elisp/fileio.scm new file mode 100644 index 000000000..805cca2d3 --- /dev/null +++ b/src/elisp/fileio.scm @@ -0,0 +1,814 @@ +#| -*- 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)) + +(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.") + +(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))))))))) + +;;;; 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))) diff --git a/src/elisp/fns.scm b/src/elisp/fns.scm new file mode 100644 index 000000000..66a0b8f09 --- /dev/null +++ b/src/elisp/fns.scm @@ -0,0 +1,519 @@ +#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*- + +$Id: $ + +Copyright (c) 1993 Matthew Birkholz, All Rights Reserved + +Random utility Lisp functions. |# + +(declare (usual-integrations)) + +(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 (stringascii 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 diff --git a/src/elisp/indent.scm b/src/elisp/indent.scm new file mode 100644 index 000000000..24a8ff255 --- /dev/null +++ b/src/elisp/indent.scm @@ -0,0 +1,102 @@ +#| -*- Mode: Scheme; Package: (elisp); Syntax: elisp-syntax-table -*- + +$Id: $ + +Copyright (c) 1993 Matthew Birkholz, All Rights Reserved + +Indentation functions. |# + +(declare (usual-integrations)) + +(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 diff --git a/src/elisp/keymap.scm b/src/elisp/keymap.scm new file mode 100644 index 000000000..a7d640a3b --- /dev/null +++ b/src/elisp/keymap.scm @@ -0,0 +1,680 @@ +#| -*- 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)) + +(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)) + +;;; 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")))) + +(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)) + +(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) + ;; (" " ""...) 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"))) + +(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.") + +;;;; 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 ).") + (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 diff --git a/src/elisp/lisp.scm b/src/elisp/lisp.scm new file mode 100644 index 000000000..fb1c1194c --- /dev/null +++ b/src/elisp/lisp.scm @@ -0,0 +1,204 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/lread.scm b/src/elisp/lread.scm new file mode 100644 index 000000000..f48485bfe --- /dev/null +++ b/src/elisp/lread.scm @@ -0,0 +1,320 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/make.scm b/src/elisp/make.scm new file mode 100644 index 000000000..7bbdb69bb --- /dev/null +++ b/src/elisp/make.scm @@ -0,0 +1,10 @@ +#| -*-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 diff --git a/src/elisp/marker.scm b/src/elisp/marker.scm new file mode 100644 index 000000000..9f9b856a5 --- /dev/null +++ b/src/elisp/marker.scm @@ -0,0 +1,75 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/minibuf.scm b/src/elisp/minibuf.scm new file mode 100644 index 000000000..492f35993 --- /dev/null +++ b/src/elisp/minibuf.scm @@ -0,0 +1,428 @@ +#| -*- 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)) + +(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 )))" + (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) + stringmode (%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))) + +(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))) + +(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)) + +(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.") + +(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 diff --git a/src/elisp/print.scm b/src/elisp/print.scm new file mode 100644 index 000000000..a30588ea6 --- /dev/null +++ b/src/elisp/print.scm @@ -0,0 +1,282 @@ +#| -*- 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)) + +(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 "#" 0 16 stdout)) + (escape? + (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 "#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 "#" 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: + ;; : insert at current point + ;; : insert at marker + ;; : 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 diff --git a/src/elisp/process.scm b/src/elisp/process.scm new file mode 100644 index 000000000..9d498ddc2 --- /dev/null +++ b/src/elisp/process.scm @@ -0,0 +1,419 @@ +#| -*- 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)) + +(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)) + '()) + +(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 '())))) + +(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)) + +(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.")|# + +(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)) + +(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)) + '()) + +(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)) + +(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 diff --git a/src/elisp/search.scm b/src/elisp/search.scm new file mode 100644 index 000000000..70d39d3e2 --- /dev/null +++ b/src/elisp/search.scm @@ -0,0 +1,435 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/syntax.scm b/src/elisp/syntax.scm new file mode 100644 index 000000000..744ba5d0f --- /dev/null +++ b/src/elisp/syntax.scm @@ -0,0 +1,230 @@ +#| -*- 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)) + +(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 diff --git a/src/elisp/window.scm b/src/elisp/window.scm new file mode 100644 index 000000000..4414d21cc --- /dev/null +++ b/src/elisp/window.scm @@ -0,0 +1,502 @@ +#| -*- 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)) + +(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