lisp/emulation/mlconvert.el

   1 ;;; mlconvert.el --- convert buffer of Mocklisp code to real lisp.
   2
   3 ;; Copyright (C) 1985 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: emulations
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This package converts Mocklisp code written under a Gosling or UniPress
  28 ;; Emacs for use with GNU Emacs.  The translated code will require runtime
  29 ;; support from the mlsupport.el equivalent.
  30
  31 ;;; Code:
  32
  33 ;;;###autoload
  34 (defun convert-mocklisp-buffer ()
  35   "Convert buffer of Mocklisp code to real Lisp that GNU Emacs can run."
  36   (interactive)
  37   (emacs-lisp-mode)
  38   (set-syntax-table (copy-sequence (syntax-table)))
  39   (modify-syntax-entry ?\| "w")
  40   (message "Converting mocklisp (ugh!)...")
  41   (goto-char (point-min))
  42   (fix-mlisp-syntax)
  43
  44   ;; Emulation of mocklisp is accurate only within a mocklisp-function
  45   ;; so turn any non-function into a defun and then call it.
  46   (goto-char (point-min))
  47   (condition-case ignore
  48       (while t
  49         (let ((opt (point))
  50               (form (read (current-buffer))))
  51           (and (listp form)
  52                (not (eq (car form) 'defun))
  53                (progn (insert "))\n\n(ml-foo)\n\n")
  54                       (save-excursion
  55                         (goto-char opt)
  56                         (skip-chars-forward "\n")
  57                         (insert "(defun (ml-foo \n "))))))
  58     (end-of-file nil))
  59
  60   (goto-char (point-min))
  61   (insert ";;; GNU Emacs code converted from Mocklisp\n")
  62   (insert "(require 'mlsupport)\n\n")
  63   (fix-mlisp-symbols)
  64
  65   (goto-char (point-min))
  66   (message "Converting mocklisp...done"))
  67
  68 (defun fix-mlisp-syntax ()
  69   (while (re-search-forward "['\"]" nil t)
  70     (if (= (preceding-char) ?\")
  71         (progn (forward-char -1)
  72                (forward-sexp 1))
  73       (delete-char -1)
  74       (insert "?")
  75     (if (or (= (following-char) ?\\) (= (following-char) ?^))
  76           (forward-char 1)
  77         (if (looking-at "[^a-zA-Z]")
  78             (insert ?\\)))
  79       (forward-char 1)
  80       (delete-char 1))))
  81
  82 (defun fix-mlisp-symbols ()
  83   (while (progn
  84            (skip-chars-forward " \t\n()")
  85            (not (eobp)))
  86     (cond ((or (= (following-char) ?\?)
  87                (= (following-char) ?\"))
  88            (forward-sexp 1))
  89           ((= (following-char) ?\;)
  90            (forward-line 1))
  91           (t
  92            (let ((start (point)) prop)
  93              (forward-sexp 1)
  94              (setq prop (get (intern-soft (buffer-substring start (point)))
  95                              'mocklisp))
  96              (cond ((null prop))
  97                    ((stringp prop)
  98                     (delete-region start (point))
  99                     (insert prop))
 100                    (t
 101                     (save-excursion
 102                       (goto-char start)
 103                       (funcall prop)))))))))
 104
 105 (defun ml-expansion (ml-name lisp-string)
 106   (put ml-name 'mocklisp lisp-string))
 107
 108 (ml-expansion 'defun "ml-defun")
 109 (ml-expansion 'if "ml-if")
 110 (ml-expansion 'setq (lambda ()
 111                        (if (looking-at "setq[ \t\n]+buffer-modified-p")
 112                            (replace-match "set-buffer-modified-p"))))
 113
 114 ;;(ml-expansion 'while (lambda ()
 115 ;;                       (let ((end (progn (forward-sexp 2) (point-marker)))
 116 ;;                             (start (progn (forward-sexp -1) (point))))
 117 ;;                         (let ((cond (buffer-substring start end)))
 118 ;;                           (cond ((equal cond "1")
 119 ;;                                  (delete-region (point) end)
 120 ;;                                  (insert "t"))
 121 ;;                                 (t
 122 ;;                                  (insert "(not (zerop ")
 123 ;;                                  (goto-char end)
 124 ;;                                  (insert "))")))
 125 ;;                           (set-marker end nil)
 126 ;;                           (goto-char start)))))
 127
 128 (ml-expansion 'arg "ml-arg")
 129 (ml-expansion 'nargs "ml-nargs")
 130 (ml-expansion 'interactive "ml-interactive")
 131 (ml-expansion 'message "ml-message")
 132 (ml-expansion 'print "ml-print")
 133 (ml-expansion 'set "ml-set")
 134 (ml-expansion 'set-default "ml-set-default")
 135 (ml-expansion 'provide-prefix-argument "ml-provide-prefix-argument")
 136 (ml-expansion 'prefix-argument-loop "ml-prefix-argument-loop")
 137 (ml-expansion 'prefix-argument "ml-prefix-arg")
 138 (ml-expansion 'use-local-map "ml-use-local-map")
 139 (ml-expansion 'use-global-map "ml-use-global-map")
 140 (ml-expansion 'modify-syntax-entry "ml-modify-syntax-entry")
 141 (ml-expansion 'error-message "error")
 142
 143 (ml-expansion 'dot "point-marker")
 144 (ml-expansion 'mark "mark-marker")
 145 (ml-expansion 'beginning-of-file "beginning-of-buffer")
 146 (ml-expansion 'end-of-file "end-of-buffer")
 147 (ml-expansion 'exchange-dot-and-mark "exchange-point-and-mark")
 148 (ml-expansion 'set-mark "set-mark-command")
 149 (ml-expansion 'argument-prefix "universal-arg")
 150
 151 (ml-expansion 'previous-page "ml-previous-page")
 152 (ml-expansion 'next-page "ml-next-page")
 153 (ml-expansion 'next-window "ml-next-window")
 154 (ml-expansion 'previous-window "ml-previous-window")
 155
 156 (ml-expansion 'newline "ml-newline")
 157 (ml-expansion 'next-line "ml-next-line")
 158 (ml-expansion 'previous-line "ml-previous-line")
 159 (ml-expansion 'self-insert "self-insert-command")
 160 (ml-expansion 'meta-digit "digit-argument")
 161 (ml-expansion 'meta-minus "negative-argument")
 162
 163 (ml-expansion 'newline-and-indent "ml-newline-and-indent")
 164 (ml-expansion 'yank-from-killbuffer "yank")
 165 (ml-expansion 'yank-buffer "insert-buffer")
 166 (ml-expansion 'copy-region "copy-region-as-kill")
 167 (ml-expansion 'delete-white-space "delete-horizontal-space")
 168 (ml-expansion 'widen-region "widen")
 169
 170 (ml-expansion 'forward-word (lambda ()
 171                                (if (looking-at "forward-word[ \t\n]*)")
 172                                    (replace-match "forward-word 1)"))))
 173 (ml-expansion 'backward-word (lambda ()
 174                                (if (looking-at "backward-word[ \t\n]*)")
 175                                    (replace-match "backward-word 1)"))))
 176
 177 (ml-expansion 'forward-paren "forward-list")
 178 (ml-expansion 'backward-paren "backward-list")
 179 (ml-expansion 'search-reverse "ml-search-backward")
 180 (ml-expansion 're-search-reverse "ml-re-search-backward")
 181 (ml-expansion 'search-forward "ml-search-forward")
 182 (ml-expansion 're-search-forward "ml-re-search-forward")
 183 (ml-expansion 'quote "regexp-quote")
 184 (ml-expansion 're-query-replace "query-replace-regexp")
 185 (ml-expansion 're-replace-string "replace-regexp")
 186
 187 ; forward-paren-bl, backward-paren-bl
 188
 189 (ml-expansion 'get-tty-character "read-char")
 190 (ml-expansion 'get-tty-input "read-input")
 191 (ml-expansion 'get-tty-string "read-string")
 192 (ml-expansion 'get-tty-buffer "read-buffer")
 193 (ml-expansion 'get-tty-command "read-command")
 194 (ml-expansion 'get-tty-variable "read-variable")
 195 (ml-expansion 'get-tty-no-blanks-input "read-no-blanks-input")
 196 (ml-expansion 'get-tty-key "read-key")
 197
 198 (ml-expansion 'concat "ml-concat")
 199 (ml-expansion 'c= "char-equal")
 200 (ml-expansion 'goto-character "goto-char")
 201 (ml-expansion 'substr "ml-substr")
 202 (ml-expansion 'variable-apropos "apropos")
 203 (ml-expansion 'execute-mlisp-buffer "eval-current-buffer")
 204 (ml-expansion 'execute-mlisp-file "load")
 205 (ml-expansion 'visit-file "find-file")
 206 (ml-expansion 'read-file "find-file")
 207 (ml-expansion 'write-modified-files "save-some-buffers")
 208 (ml-expansion 'backup-before-writing "make-backup-files")
 209 (ml-expansion 'write-file-exit "save-buffers-kill-emacs")
 210 (ml-expansion 'write-named-file "write-file")
 211 (ml-expansion 'change-file-name "set-visited-file-name")
 212 (ml-expansion 'change-buffer-name "rename-buffer")
 213 (ml-expansion 'buffer-exists "get-buffer")
 214 (ml-expansion 'delete-buffer "kill-buffer")
 215 (ml-expansion 'unlink-file "delete-file")
 216 (ml-expansion 'unlink-checkpoint-files "delete-auto-save-files")
 217 (ml-expansion 'file-exists "file-exists-p")
 218 (ml-expansion 'write-current-file "save-buffer")
 219 (ml-expansion 'change-directory "cd")
 220 (ml-expansion 'temp-use-buffer "set-buffer")
 221 (ml-expansion 'fast-filter-region "filter-region")
 222
 223 (ml-expansion 'pending-input "input-pending-p")
 224 (ml-expansion 'execute-keyboard-macro "call-last-kbd-macro")
 225 (ml-expansion 'start-remembering "start-kbd-macro")
 226 (ml-expansion 'end-remembering "end-kbd-macro")
 227 (ml-expansion 'define-keyboard-macro "name-last-kbd-macro")
 228 (ml-expansion 'define-string-macro "ml-define-string-macro")
 229
 230 (ml-expansion 'current-column "ml-current-column")
 231 (ml-expansion 'current-indent "ml-current-indent")
 232 (ml-expansion 'insert-character "insert")
 233
 234 (ml-expansion 'users-login-name "user-login-name")
 235 (ml-expansion 'users-full-name "user-full-name")
 236 (ml-expansion 'current-time "current-time-string")
 237 (ml-expansion 'current-numeric-time "current-numeric-time-you-lose")
 238 (ml-expansion 'current-buffer-name "buffer-name")
 239 (ml-expansion 'current-file-name "buffer-file-name")
 240
 241 (ml-expansion 'local-binding-of "local-key-binding")
 242 (ml-expansion 'global-binding-of "global-key-binding")
 243
 244 ;defproc (ProcedureType, "procedure-type");
 245
 246 (ml-expansion 'remove-key-binding "global-unset-key")
 247 (ml-expansion 'remove-binding "global-unset-key")
 248 (ml-expansion 'remove-local-binding "local-unset-key")
 249 (ml-expansion 'remove-all-local-bindings "use-local-map nil")
 250 (ml-expansion 'autoload "ml-autoload")
 251
 252 (ml-expansion 'checkpoint-frequency "auto-save-interval")
 253
 254 (ml-expansion 'mode-string "mode-name")
 255 (ml-expansion 'right-margin "fill-column")
 256 (ml-expansion 'tab-size "tab-width")
 257 (ml-expansion 'default-right-margin "default-fill-column")
 258 (ml-expansion 'default-tab-size "default-tab-width")
 259 (ml-expansion 'buffer-is-modified "(buffer-modified-p)")
 260
 261 (ml-expansion 'file-modified-time "you-lose-on-file-modified-time")
 262 (ml-expansion 'needs-checkpointing "you-lose-on-needs-checkpointing")
 263
 264 (ml-expansion 'lines-on-screen "set-frame-height")
 265 (ml-expansion 'columns-on-screen "set-frame-width")
 266
 267 (ml-expansion 'dumped-emacs "t")
 268
 269 (ml-expansion 'buffer-size "ml-buffer-size")
 270 (ml-expansion 'dot-is-visible "pos-visible-in-window-p")
 271
 272 (ml-expansion 'track-eol-on-^N-^P "track-eol")
 273 (ml-expansion 'ctlchar-with-^ "ctl-arrow")
 274 (ml-expansion 'help-on-command-completion-error "completion-auto-help")
 275 (ml-expansion 'dump-stack-trace "backtrace")
 276 (ml-expansion 'pause-emacs "suspend-emacs")
 277 (ml-expansion 'compile-it "compile")
 278
 279 (ml-expansion '!= "/=")
 280 (ml-expansion '& "logand")
 281 (ml-expansion '| "logior")
 282 (ml-expansion '^ "logxor")
 283 (ml-expansion '! "ml-not")
 284 (ml-expansion '<< "lsh")
 285
 286 ;Variable pause-writes-files
 287
 288 ;;; mlconvert.el ends here