Mercurial > emacs
changeset 42280:6a18a8267c6a
Files removed.
| author | Pavel Janík <Pavel@Janik.cz> |
|---|---|
| date | Sat, 22 Dec 2001 14:13:11 +0000 |
| parents | 26edff7f8f45 |
| children | 18095fb6473e |
| files | lisp/emulation/mlconvert.el lisp/emulation/mlsupport.el src/mocklisp.c src/mocklisp.h |
| diffstat | 4 files changed, 0 insertions(+), 939 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/emulation/mlconvert.el Sat Dec 22 14:02:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,288 +0,0 @@ -;;; mlconvert.el --- convert buffer of Mocklisp code to real lisp - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: emulations - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package converts Mocklisp code written under a Gosling or UniPress -;; Emacs for use with GNU Emacs. The translated code will require runtime -;; support from the mlsupport.el equivalent. - -;;; Code: - -;;;###autoload -(defun convert-mocklisp-buffer () - "Convert buffer of Mocklisp code to real Lisp that GNU Emacs can run." - (interactive) - (emacs-lisp-mode) - (set-syntax-table (copy-sequence (syntax-table))) - (modify-syntax-entry ?\| "w") - (message "Converting mocklisp (ugh!)...") - (goto-char (point-min)) - (fix-mlisp-syntax) - - ;; Emulation of mocklisp is accurate only within a mocklisp-function - ;; so turn any non-function into a defun and then call it. - (goto-char (point-min)) - (condition-case ignore - (while t - (let ((opt (point)) - (form (read (current-buffer)))) - (and (listp form) - (not (eq (car form) 'defun)) - (progn (insert "))\n\n(ml-foo)\n\n") - (save-excursion - (goto-char opt) - (skip-chars-forward "\n") - (insert "(defun (ml-foo \n ")))))) - (end-of-file nil)) - - (goto-char (point-min)) - (insert ";;; GNU Emacs code converted from Mocklisp\n") - (insert "(require 'mlsupport)\n\n") - (fix-mlisp-symbols) - - (goto-char (point-min)) - (message "Converting mocklisp...done")) - -(defun fix-mlisp-syntax () - (while (re-search-forward "['\"]" nil t) - (if (= (preceding-char) ?\") - (progn (forward-char -1) - (forward-sexp 1)) - (delete-char -1) - (insert "?") - (if (or (= (following-char) ?\\) (= (following-char) ?^)) - (forward-char 1) - (if (looking-at "[^a-zA-Z]") - (insert ?\\))) - (forward-char 1) - (delete-char 1)))) - -(defun fix-mlisp-symbols () - (while (progn - (skip-chars-forward " \t\n()") - (not (eobp))) - (cond ((or (= (following-char) ?\?) - (= (following-char) ?\")) - (forward-sexp 1)) - ((= (following-char) ?\;) - (forward-line 1)) - (t - (let ((start (point)) prop) - (forward-sexp 1) - (setq prop (get (intern-soft (buffer-substring start (point))) - 'mocklisp)) - (cond ((null prop)) - ((stringp prop) - (delete-region start (point)) - (insert prop)) - (t - (save-excursion - (goto-char start) - (funcall prop))))))))) - -(defun ml-expansion (ml-name lisp-string) - (put ml-name 'mocklisp lisp-string)) - -(ml-expansion 'defun "ml-defun") -(ml-expansion 'if "ml-if") -(ml-expansion 'setq (lambda () - (if (looking-at "setq[ \t\n]+buffer-modified-p") - (replace-match "set-buffer-modified-p")))) - -;;(ml-expansion 'while (lambda () -;; (let ((end (progn (forward-sexp 2) (point-marker))) -;; (start (progn (forward-sexp -1) (point)))) -;; (let ((cond (buffer-substring start end))) -;; (cond ((equal cond "1") -;; (delete-region (point) end) -;; (insert "t")) -;; (t -;; (insert "(not (zerop ") -;; (goto-char end) -;; (insert "))"))) -;; (set-marker end nil) -;; (goto-char start))))) - -(ml-expansion 'arg "ml-arg") -(ml-expansion 'nargs "ml-nargs") -(ml-expansion 'interactive "ml-interactive") -(ml-expansion 'message "ml-message") -(ml-expansion 'print "ml-print") -(ml-expansion 'set "ml-set") -(ml-expansion 'set-default "ml-set-default") -(ml-expansion 'provide-prefix-argument "ml-provide-prefix-argument") -(ml-expansion 'prefix-argument-loop "ml-prefix-argument-loop") -(ml-expansion 'prefix-argument "ml-prefix-arg") -(ml-expansion 'use-local-map "ml-use-local-map") -(ml-expansion 'use-global-map "ml-use-global-map") -(ml-expansion 'modify-syntax-entry "ml-modify-syntax-entry") -(ml-expansion 'error-message "error") - -(ml-expansion 'dot "point-marker") -(ml-expansion 'mark "mark-marker") -(ml-expansion 'beginning-of-file "beginning-of-buffer") -(ml-expansion 'end-of-file "end-of-buffer") -(ml-expansion 'exchange-dot-and-mark "exchange-point-and-mark") -(ml-expansion 'set-mark "set-mark-command") -(ml-expansion 'argument-prefix "universal-arg") - -(ml-expansion 'previous-page "ml-previous-page") -(ml-expansion 'next-page "ml-next-page") -(ml-expansion 'next-window "ml-next-window") -(ml-expansion 'previous-window "ml-previous-window") - -(ml-expansion 'newline "ml-newline") -(ml-expansion 'next-line "ml-next-line") -(ml-expansion 'previous-line "ml-previous-line") -(ml-expansion 'self-insert "self-insert-command") -(ml-expansion 'meta-digit "digit-argument") -(ml-expansion 'meta-minus "negative-argument") - -(ml-expansion 'newline-and-indent "ml-newline-and-indent") -(ml-expansion 'yank-from-killbuffer "yank") -(ml-expansion 'yank-buffer "insert-buffer") -(ml-expansion 'copy-region "copy-region-as-kill") -(ml-expansion 'delete-white-space "delete-horizontal-space") -(ml-expansion 'widen-region "widen") - -(ml-expansion 'forward-word (lambda () - (if (looking-at "forward-word[ \t\n]*)") - (replace-match "forward-word 1)")))) -(ml-expansion 'backward-word (lambda () - (if (looking-at "backward-word[ \t\n]*)") - (replace-match "backward-word 1)")))) - -(ml-expansion 'forward-paren "forward-list") -(ml-expansion 'backward-paren "backward-list") -(ml-expansion 'search-reverse "ml-search-backward") -(ml-expansion 're-search-reverse "ml-re-search-backward") -(ml-expansion 'search-forward "ml-search-forward") -(ml-expansion 're-search-forward "ml-re-search-forward") -(ml-expansion 'quote "regexp-quote") -(ml-expansion 're-query-replace "query-replace-regexp") -(ml-expansion 're-replace-string "replace-regexp") - -; forward-paren-bl, backward-paren-bl - -(ml-expansion 'get-tty-character "read-char") -(ml-expansion 'get-tty-input "read-input") -(ml-expansion 'get-tty-string "read-string") -(ml-expansion 'get-tty-buffer "read-buffer") -(ml-expansion 'get-tty-command "read-command") -(ml-expansion 'get-tty-variable "read-variable") -(ml-expansion 'get-tty-no-blanks-input "read-no-blanks-input") -(ml-expansion 'get-tty-key "read-key") - -(ml-expansion 'concat "ml-concat") -(ml-expansion 'c= "char-equal") -(ml-expansion 'goto-character "goto-char") -(ml-expansion 'substr "ml-substr") -(ml-expansion 'variable-apropos "apropos") -(ml-expansion 'execute-mlisp-buffer "eval-current-buffer") -(ml-expansion 'execute-mlisp-file "load") -(ml-expansion 'visit-file "find-file") -(ml-expansion 'read-file "find-file") -(ml-expansion 'write-modified-files "save-some-buffers") -(ml-expansion 'backup-before-writing "make-backup-files") -(ml-expansion 'write-file-exit "save-buffers-kill-emacs") -(ml-expansion 'write-named-file "write-file") -(ml-expansion 'change-file-name "set-visited-file-name") -(ml-expansion 'change-buffer-name "rename-buffer") -(ml-expansion 'buffer-exists "get-buffer") -(ml-expansion 'delete-buffer "kill-buffer") -(ml-expansion 'unlink-file "delete-file") -(ml-expansion 'unlink-checkpoint-files "delete-auto-save-files") -(ml-expansion 'file-exists "file-exists-p") -(ml-expansion 'write-current-file "save-buffer") -(ml-expansion 'change-directory "cd") -(ml-expansion 'temp-use-buffer "set-buffer") -(ml-expansion 'fast-filter-region "filter-region") - -(ml-expansion 'pending-input "input-pending-p") -(ml-expansion 'execute-keyboard-macro "call-last-kbd-macro") -(ml-expansion 'start-remembering "start-kbd-macro") -(ml-expansion 'end-remembering "end-kbd-macro") -(ml-expansion 'define-keyboard-macro "name-last-kbd-macro") -(ml-expansion 'define-string-macro "ml-define-string-macro") - -(ml-expansion 'current-column "ml-current-column") -(ml-expansion 'current-indent "ml-current-indent") -(ml-expansion 'insert-character "insert") - -(ml-expansion 'users-login-name "user-login-name") -(ml-expansion 'users-full-name "user-full-name") -(ml-expansion 'current-time "current-time-string") -(ml-expansion 'current-numeric-time "current-numeric-time-you-lose") -(ml-expansion 'current-buffer-name "buffer-name") -(ml-expansion 'current-file-name "buffer-file-name") - -(ml-expansion 'local-binding-of "local-key-binding") -(ml-expansion 'global-binding-of "global-key-binding") - -;defproc (ProcedureType, "procedure-type"); - -(ml-expansion 'remove-key-binding "global-unset-key") -(ml-expansion 'remove-binding "global-unset-key") -(ml-expansion 'remove-local-binding "local-unset-key") -(ml-expansion 'remove-all-local-bindings "use-local-map nil") -(ml-expansion 'autoload "ml-autoload") - -(ml-expansion 'checkpoint-frequency "auto-save-interval") - -(ml-expansion 'mode-string "mode-name") -(ml-expansion 'right-margin "fill-column") -(ml-expansion 'tab-size "tab-width") -(ml-expansion 'default-right-margin "default-fill-column") -(ml-expansion 'default-tab-size "default-tab-width") -(ml-expansion 'buffer-is-modified "(buffer-modified-p)") - -(ml-expansion 'file-modified-time "you-lose-on-file-modified-time") -(ml-expansion 'needs-checkpointing "you-lose-on-needs-checkpointing") - -(ml-expansion 'lines-on-screen "set-frame-height") -(ml-expansion 'columns-on-screen "set-frame-width") - -(ml-expansion 'dumped-emacs "t") - -(ml-expansion 'buffer-size "ml-buffer-size") -(ml-expansion 'dot-is-visible "pos-visible-in-window-p") - -(ml-expansion 'track-eol-on-^N-^P "track-eol") -(ml-expansion 'ctlchar-with-^ "ctl-arrow") -(ml-expansion 'help-on-command-completion-error "completion-auto-help") -(ml-expansion 'dump-stack-trace "backtrace") -(ml-expansion 'pause-emacs "suspend-emacs") -(ml-expansion 'compile-it "compile") - -(ml-expansion '!= "/=") -(ml-expansion '& "logand") -(ml-expansion '| "logior") -(ml-expansion '^ "logxor") -(ml-expansion '! "ml-not") -(ml-expansion '<< "lsh") - -;Variable pause-writes-files - -;;; mlconvert.el ends here
--- a/lisp/emulation/mlsupport.el Sat Dec 22 14:02:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,435 +0,0 @@ -;;; mlsupport.el --- run-time support for mocklisp code - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: extensions - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This package provides equivalents of certain primitives from Gosling -;; Emacs (including the commercial UniPress versions). These have an -;; ml- prefix to distinguish them from native GNU Emacs functions with -;; similar names. The package mlconvert.el translates Mocklisp code -;; to use these names. - -;;; Code: - -(defmacro ml-defun (&rest defs) - (list 'ml-defun-1 (list 'quote defs))) - -(defun ml-defun-1 (args) - (while args - (fset (car (car args)) (cons 'mocklisp (cdr (car args)))) - (setq args (cdr args)))) - -(defmacro declare-buffer-specific (&rest vars) - (cons 'progn (mapcar (function (lambda (var) (list 'make-variable-buffer-local (list 'quote var)))) vars))) - -(defun ml-set-default (varname value) - (set-default (intern varname) value)) - -; Lossage: must make various things default missing args to the prefix arg -; Alternatively, must make provide-prefix-argument do something hairy. - -(defun >> (val count) (lsh val (- count))) -(defun novalue () nil) - -(defun ml-not (arg) (if (zerop arg) 1 0)) - -(defun provide-prefix-arg (arg form) - (funcall (car form) arg)) - -(defun define-keymap (name) - (fset (intern name) (make-keymap))) - -;; Make it work to use ml-use-...-map on "esc" and such. -(fset 'esc-map esc-map) -(fset 'ctl-x-map ctl-x-map) - -(defun ml-use-local-map (name) - (use-local-map (intern (concat name "-map")))) - -(defun ml-use-global-map (name) - (use-global-map (intern (concat name "-map")))) - -(defun local-bind-to-key (name key) - (or (current-local-map) - (use-local-map (make-keymap))) - (define-key (current-local-map) - (if (integerp key) - (if (>= key 128) - (concat (char-to-string meta-prefix-char) - (char-to-string (- key 128))) - (char-to-string key)) - key) - (intern name))) - -(defun bind-to-key (name key) - (define-key global-map (if (integerp key) (char-to-string key) key) - (intern name))) - -(defun ml-autoload (name file) - (autoload (intern name) file)) - -(defun ml-define-string-macro (name defn) - (fset (intern name) defn)) - -(defun push-back-character (char) - (setq unread-command-events (list char))) - -(defun to-col (column) - (indent-to column 0)) - -(defmacro is-bound (&rest syms) - (cons 'and (mapcar (function (lambda (sym) (list 'boundp (list 'quote sym)))) syms))) - -(defmacro declare-global (&rest syms) - (cons 'progn (mapcar (function (lambda (sym) (list 'defvar sym nil))) syms))) - -(defmacro error-occurred (&rest body) - (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t))) - -(defun return-prefix-argument (value) - (setq prefix-arg value)) - -(defun ml-prefix-argument () - (if (null current-prefix-arg) 1 - (if (listp current-prefix-arg) (car current-prefix-arg) - (if (eq current-prefix-arg '-) -1 - current-prefix-arg)))) - -(defun ml-print (varname) - (interactive "vPrint variable: ") - (if (boundp varname) - (message "%s => %s" (symbol-name varname) (symbol-value varname)) - (message "%s has no value" (symbol-name varname)))) - -(defun ml-set (str val) (set (intern str) val)) - -(defun ml-message (&rest args) (message "%s" (apply 'concat args))) - -(defun kill-to-end-of-line () - (ml-prefix-argument-loop - (if (eolp) - (kill-region (point) (1+ (point))) - (kill-region (point) (if (search-forward ?\n nil t) - (1- (point)) (point-max)))))) - -(defun set-auto-fill-hook (arg) - (setq auto-fill-function (intern arg))) - -(defun auto-execute (function pattern) - (if (/= (aref pattern 0) ?*) - (error "Only patterns starting with * supported in auto-execute")) - (setq auto-mode-alist (cons (cons (concat "\\." (substring pattern 1) - "\\'") - function) - auto-mode-alist))) - -(defun move-to-comment-column () - (indent-to comment-column)) - -(defun erase-region () - (delete-region (point) (mark))) - -(defun delete-region-to-buffer (bufname) - (copy-to-buffer bufname (point) (mark)) - (delete-region (point) (mark))) - -(defun copy-region-to-buffer (bufname) - (copy-to-buffer bufname (point) (mark))) - -(defun append-region-to-buffer (bufname) - (append-to-buffer bufname (point) (mark))) - -(defun prepend-region-to-buffer (bufname) - (prepend-to-buffer bufname (point) (mark))) - -(defun delete-next-character () - (delete-char (ml-prefix-argument))) - -(defun delete-next-word () - (delete-region (point) (progn (forward-word (ml-prefix-argument)) (point)))) - -(defun delete-previous-word () - (delete-region (point) (progn (backward-word (ml-prefix-argument)) (point)))) - -(defun delete-previous-character () - (delete-backward-char (ml-prefix-argument))) - -(defun forward-character () - (forward-char (ml-prefix-argument))) - -(defun backward-character () - (backward-char (ml-prefix-argument))) - -(defun ml-newline () - (newline (ml-prefix-argument))) - -(defun ml-next-line () - (next-line (ml-prefix-argument))) - -(defun ml-previous-line () - (previous-line (ml-prefix-argument))) - -(defun delete-to-kill-buffer () - (kill-region (point) (mark))) - -(defun narrow-region () - (narrow-to-region (point) (mark))) - -(defun ml-newline-and-indent () - (let ((column (current-indentation))) - (newline (ml-prefix-argument)) - (indent-to column))) - -(defun newline-and-backup () - (open-line (ml-prefix-argument))) - -(defun quote-char () - (quoted-insert (ml-prefix-argument))) - -(defun ml-current-column () - (1+ (current-column))) - -(defun ml-current-indent () - (1+ (current-indentation))) - -(defun region-around-match (&optional n) - (set-mark (match-beginning n)) - (goto-char (match-end n))) - -(defun region-to-string () - (buffer-substring (min (point) (mark)) (max (point) (mark)))) - -(defun use-abbrev-table (name) - (let ((symbol (intern (concat name "-abbrev-table")))) - (or (boundp symbol) - (define-abbrev-table symbol nil)) - (symbol-value symbol))) - -(defun define-hooked-local-abbrev (name exp hook) - (define-abbrev local-abbrev-table name exp (intern hook))) - -(defun define-hooked-global-abbrev (name exp hook) - (define-abbrev global-abbrev-table name exp (intern hook))) - -(defun case-word-lower () - (ml-casify-word 'downcase-region)) - -(defun case-word-upper () - (ml-casify-word 'upcase-region)) - -(defun case-word-capitalize () - (ml-casify-word 'capitalize-region)) - -(defun ml-casify-word (fun) - (save-excursion - (forward-char 1) - (forward-word -1) - (funcall fun (point) - (progn (forward-word (ml-prefix-argument)) - (point))))) - -(defun case-region-lower () - (downcase-region (point) (mark))) - -(defun case-region-upper () - (upcase-region (point) (mark))) - -(defun case-region-capitalize () - (capitalize-region (point) (mark))) - -(defvar saved-command-line-args nil) - -(defun argc () - (or saved-command-line-args - (setq saved-command-line-args command-line-args - command-line-args ())) - (length command-line-args)) - -(defun argv (i) - (or saved-command-line-args - (setq saved-command-line-args command-line-args - command-line-args ())) - (nth i saved-command-line-args)) - -(defun invisible-argc () - (length (or saved-command-line-args - command-line-args))) - -(defun invisible-argv (i) - (nth i (or saved-command-line-args - command-line-args))) - -(defun exit-emacs () - (interactive) - (condition-case () - (exit-recursive-edit) - (error (kill-emacs)))) - -;; Lisp function buffer-size returns total including invisible; -;; mocklisp wants just visible. -(defun ml-buffer-size () - (- (point-max) (point-min))) - -(defun previous-command () - last-command) - -(defun beginning-of-window () - (goto-char (window-start))) - -(defun end-of-window () - (goto-char (window-start)) - (vertical-motion (- (window-height) 2))) - -(defun ml-search-forward (string) - (search-forward string nil nil (ml-prefix-argument))) - -(defun ml-re-search-forward (string) - (re-search-forward string nil nil (ml-prefix-argument))) - -(defun ml-search-backward (string) - (search-backward string nil nil (ml-prefix-argument))) - -(defun ml-re-search-backward (string) - (re-search-backward string nil nil (ml-prefix-argument))) - -(defvar use-users-shell 1 - "Mocklisp compatibility variable; 1 means use shell from SHELL env var. -0 means use /bin/sh.") - -(defvar use-csh-option-f 1 - "Mocklisp compatibility variable; 1 means pass -f when calling csh.") - -(defun filter-region (command) - (let ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh")) - (csh (equal (file-name-nondirectory shell) "csh"))) - (call-process-region (point) (mark) shell t t nil - (if (and csh use-csh-option-f) "-cf" "-c") - (concat "exec " command)))) - -(defun execute-monitor-command (command) - (let ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh")) - (csh (equal (file-name-nondirectory shell) "csh"))) - (call-process shell nil t t - (if (and csh use-csh-option-f) "-cf" "-c") - (concat "exec " command)))) - -(defun use-syntax-table (name) - (set-syntax-table (symbol-value (intern (concat name "-syntax-table"))))) - -(defun line-to-top-of-window () - (recenter (1- (ml-prefix-argument)))) - -(defun ml-previous-page (&optional arg) - (let ((count (or arg (ml-prefix-argument)))) - (while (> count 0) - (scroll-down nil) - (setq count (1- count))) - (while (< count 0) - (scroll-up nil) - (setq count (1+ count))))) - -(defun ml-next-page () - (previous-page (- (ml-prefix-argument)))) - -(defun page-next-window (&optional arg) - (let ((count (or arg (ml-prefix-argument)))) - (while (> count 0) - (scroll-other-window nil) - (setq count (1- count))) - (while (< count 0) - (scroll-other-window '-) - (setq count (1+ count))))) - -(defun ml-next-window () - (select-window (next-window))) - -(defun ml-previous-window () - (select-window (previous-window))) - -(defun scroll-one-line-up () - (scroll-up (ml-prefix-argument))) - -(defun scroll-one-line-down () - (scroll-down (ml-prefix-argument))) - -(defun split-current-window () - (split-window (selected-window))) - -(defun last-key-struck () last-command-char) - -(defun execute-mlisp-line (string) - (eval (read string))) - -(defun move-dot-to-x-y (x y) - (goto-char (window-start (selected-window))) - (vertical-motion (1- y)) - (move-to-column (1- x))) - -(defun ml-modify-syntax-entry (string) - (let ((i 5) - (len (length string)) - (datastring (substring string 0 2))) - (if (= (aref string 0) ?\-) - (aset datastring 0 ?\ )) - (if (= (aref string 2) ?\{) - (if (= (aref string 4) ?\ ) - (aset datastring 0 ?\<) - (error "Two-char comment delimiter: use modify-syntax-entry directly"))) - (if (= (aref string 3) ?\}) - (if (= (aref string 4) ?\ ) - (aset datastring 0 ?\>) - (error "Two-char comment delimiter: use modify-syntax-entry directly"))) - (while (< i len) - (modify-syntax-entry (aref string i) datastring) - (setq i (1+ i)) - (if (and (< i len) - (= (aref string i) ?\-)) - (let ((c (aref string (1- i))) - (lim (aref string (1+ i)))) - (while (<= c lim) - (modify-syntax-entry c datastring) - (setq c (1+ c))) - (setq i (+ 2 i))))))) - - - -(defun ml-substr (string from to) - (let ((length (length string))) - (if (< from 0) (setq from (+ from length))) - (if (< to 0) (setq to (+ to length))) - (substring string from (+ from to)))) - -(defun ml-concat (&rest args) - (let ((newargs nil) this) - (while args - (setq this (car args)) - (if (numberp this) - (setq this (number-to-string this))) - (setq newargs (cons this newargs) - args (cdr args))) - (apply 'concat (nreverse newargs)))) - -(provide 'mlsupport) - -;;; mlsupport.el ends here
--- a/src/mocklisp.c Sat Dec 22 14:02:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,188 +0,0 @@ -/* Mocklisp compatibility functions for GNU Emacs Lisp interpreter. - Copyright (C) 1985, 1986, 1995 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -/* Compatibility for mocklisp */ - -#include <config.h> -#include "lisp.h" -#include "buffer.h" - -DEFUN ("ml-if", Fml_if, Sml_if, 0, UNEVALLED, 0, - doc: /* Mocklisp version of `if'. -usage: (ml-if COND THEN ELSE...) */) - (args) - Lisp_Object args; -{ - register Lisp_Object val; - struct gcpro gcpro1; - - val = Qnil; - GCPRO1 (args); - while (!NILP (args)) - { - val = Feval (Fcar (args)); - args = Fcdr (args); - if (NILP (args)) break; - if (XINT (val)) - { - val = Feval (Fcar (args)); - break; - } - args = Fcdr (args); - } - UNGCPRO; - return val; -} - - -/* This is the main entry point to mocklisp execution. - When eval sees a mocklisp function being called, it calls here - with the unevaluated argument list. */ - -Lisp_Object -ml_apply (function, args) - Lisp_Object function, args; -{ - register int count = specpdl_ptr - specpdl; - register Lisp_Object val; - - specbind (Qmocklisp_arguments, args); - val = Fprogn (Fcdr (function)); - return unbind_to (count, val); -} - -DEFUN ("ml-nargs", Fml_nargs, Sml_nargs, 0, 0, 0, - doc: /* Number of arguments to currently executing mocklisp function. */) - () -{ - if (EQ (Vmocklisp_arguments, Qinteractive)) - return make_number (0); - return Flength (Vmocklisp_arguments); -} - -DEFUN ("ml-arg", Fml_arg, Sml_arg, 1, 2, 0, - doc: /* Argument number N to currently executing mocklisp function. */) - (n, prompt) - Lisp_Object n, prompt; -{ - if (EQ (Vmocklisp_arguments, Qinteractive)) - return Fread_string (prompt, Qnil, Qnil, Qnil, Qnil); - CHECK_NUMBER (n); - XSETINT (n, XINT (n) - 1); /* Mocklisp likes to be origin-1 */ - return Fcar (Fnthcdr (n, Vmocklisp_arguments)); -} - -DEFUN ("ml-interactive", Fml_interactive, Sml_interactive, 0, 0, 0, - doc: /* True if currently executing mocklisp function was called interactively. */) - () -{ - return (EQ (Vmocklisp_arguments, Qinteractive)) ? Qt : Qnil; -} - -DEFUN ("ml-provide-prefix-argument", Fml_provide_prefix_argument, Sml_provide_prefix_argument, - 2, UNEVALLED, 0, - doc: /* Evaluate second argument, using first argument as prefix arg value. -usage: (ml-provide-prefix-argument ARG1 ARG2) */) - (args) - Lisp_Object args; -{ - struct gcpro gcpro1; - GCPRO1 (args); - Vcurrent_prefix_arg = Feval (Fcar (args)); - UNGCPRO; - return Feval (Fcar (Fcdr (args))); -} - -DEFUN ("ml-prefix-argument-loop", Fml_prefix_argument_loop, Sml_prefix_argument_loop, - 0, UNEVALLED, 0, - doc: /* usage: (ml-prefix-argument-loop ...) */) - (args) - Lisp_Object args; -{ - register Lisp_Object tem; - register int i; - struct gcpro gcpro1; - - /* Set `arg' in case we call a built-in function that looks at it. Still are a few. */ - if (NILP (Vcurrent_prefix_arg)) - i = 1; - else - { - tem = Vcurrent_prefix_arg; - if (CONSP (tem)) - tem = Fcar (tem); - if (EQ (tem, Qminus)) - i = -1; - else i = XINT (tem); - } - - GCPRO1 (args); - while (i-- > 0) - Fprogn (args); - UNGCPRO; - return Qnil; -} - -DEFUN ("insert-string", Finsert_string, Sinsert_string, 0, MANY, 0, - doc: /* Mocklisp-compatibility insert function. -Like the function `insert' except that any argument that is a number -is converted into a string by expressing it in decimal. -usage: (insert-string &rest ARGS) */) - (nargs, args) - int nargs; - Lisp_Object *args; -{ - register int argnum; - register Lisp_Object tem; - - for (argnum = 0; argnum < nargs; argnum++) - { - tem = args[argnum]; - retry: - if (INTEGERP (tem)) - tem = Fnumber_to_string (tem); - if (STRINGP (tem)) - insert1 (tem); - else - { - tem = wrong_type_argument (Qstringp, tem); - goto retry; - } - } - - return Qnil; -} - - -void -syms_of_mocklisp () -{ - Qmocklisp = intern ("mocklisp"); - staticpro (&Qmocklisp); - - defsubr (&Sml_if); - defsubr (&Sml_arg); - defsubr (&Sml_nargs); - defsubr (&Sml_interactive); - defsubr (&Sml_provide_prefix_argument); - defsubr (&Sml_prefix_argument_loop); - defsubr (&Sinsert_string); -}
--- a/src/mocklisp.h Sat Dec 22 14:02:33 2001 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -/* Fundamental definitions for emulating mocklisp. - Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -extern Lisp_Object ml_apply (); -extern Lisp_Object Fml_if (); -extern Lisp_Object Fml_nargs (); -extern Lisp_Object Fml_arg (); -extern Lisp_Object Fml_interactive (); -extern Lisp_Object Fml_provide_prefix_argument (); -extern Lisp_Object Fml_prefix_argument_loop (); -extern Lisp_Object Finsert_string ();