1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 
 10 ;;;
 11 ;;;
 12 ;;; Emacs Object Mode, because it was necessary.
 13 
 14 
 15 ;;; HISTORY COMMENTS:
 16 ;;;  1) change(81-05-05,Soley), approve(), audit(),
 17 ;;;     install(86-08-20,MR12.0-1136):
 18 ;;;     pre-hcom history:
 19 ;;;     Originally written.
 20 ;;;  2) change(86-02-24,Margolin), approve(86-02-24,MCR7325),
 21 ;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
 22 ;;;     Converted to use the new e_multics_files_ primitives.  Changed the #
 23 ;;;     read-macro to the more standard #o macro.  Changed lsh/boole
 24 ;;;     combinations into ldb.
 25 ;;;                                                      END HISTORY COMMENTS
 26 
 27 ;;;
 28 
 29 (%include e-macros)
 30 (%include emacs-internal-macros)
 31 (%include defun)
 32 (%include other_other)
 33 (%include sharpsign)
 34 (%include runtime)
 35 (eval-when (eval compile load) (sstatus feature runtime))   ; write-around bug
 36 
 37 (declare (special object-mode-count object-mode-chars last-input-char
 38                   known-buflist NL object-mode-total)
 39          (*lexpr absolute-pathname close-file open-file)
 40          (*expr check-minibuffer-file-command
 41                 open-star-name-single))
 42 
 43 ;;; Returns octal string representation, padded on the left with 0.
 44 
 45 (defun pad-left-octal (number)
 46        (let ((rep (octal-rep number)))
 47             (cond ((= (stringlength rep) 3) rep)
 48                   ((= (stringlength rep) 2) (catenate "0" rep))
 49                   ('else (catenate "00" rep)))))
 50 
 51 (defun pad-left-6octal (number)
 52        (let ((rep (octal-rep number)))
 53             (catenate (substr "000000" 1 (- 6. (stringlength rep)))
 54                       rep)))
 55 
 56 ;;; Returns octal string representation.
 57 
 58 (defun octal-rep (x)
 59        (let ((base 8.) (*nopoint t))
 60             (maknam (explodec x))))
 61 
 62 ;;; This is the end-of-file-function for object-mode-read-file.
 63 
 64 (defun object-mode-eoffn (a b) a b (throw 'done object-mode-tag))
 65 
 66 ;;; This functions reads in a file, inserting the object in object-mode
 67 ;;; format into the current buffer.  Doesn't check pathname at all.
 68 
 69 (defun object-mode-read-file (pathname)
 70        (let ((read-only-flag nil))
 71             (destroy-buffer-contents)
 72             (setq object-mode-count 0 object-mode-chars ()
 73                   fpathname (e_lap_$rtrim pathname) object-mode-total 0)
 74             (let ((fo (open pathname '(in ascii fixnum))))
 75                  (eoffn fo 'object-mode-eoffn)
 76                  (minibuffer-remark "Reading...")
 77                  (catch
 78                    (do () (()) (object-mode-read-word fo))
 79                    object-mode-tag)
 80                  (close fo))
 81             (or (zerop object-mode-count) (object-mode-finish-line))
 82             (go-to-beginning-of-buffer)
 83             (setq buffer-modified-flag nil)))
 84 
 85 ;;; Function to read in one word from the input file and update
 86 ;;; the current line with that information.
 87 
 88 (defun object-mode-read-word (file)
 89        (let ((word (in file)))
 90             (setq object-mode-count (1+ object-mode-count))
 91             (let ((c1 (ldb #o3311 word))
 92                   (c2 (ldb #o2211 word))
 93                   (c3 (ldb #o1111 word))
 94                   (c4 (ldb #o0011 word)))
 95                  (setq object-mode-chars
 96                        (list* c4 c3 c2 c1 object-mode-chars))
 97                  (insert-string
 98                    (catenate (pad-left-octal c1) " "
 99                              (pad-left-octal c2) " "
100                              (pad-left-octal c3) " "
101                              (pad-left-octal c4) "   "))))
102        (and (= object-mode-count 3) (object-mode-finish-line)))
103 
104 ;;; Finish off a line of object.
105 
106 (defun object-mode-finish-line ()
107        (save-excursion
108          (go-to-beginning-of-line)
109          (insert-string (pad-left-6octal object-mode-total))
110          (insert-string "   "))
111        (setq object-mode-total (+ object-mode-total 3))
112        (or (= object-mode-count 3)
113            (do n object-mode-count (1+ n) (> n 2)
114                (insert-string "                  ")))
115        (setq object-mode-count 0)
116        (do ((n 0 (1+ n))
117             (chars (nreverse object-mode-chars) (cdr chars)))
118            ((or (null chars) (= n 12.)))
119            (and (zerop (\ n 4)) (insert-string " "))
120            (let ((this (car chars)))
121                 (object-mode-insert-letter this)))
122        (setq object-mode-chars ())
123        (new-line))
124 
125 ;;; To write an object file.  Real work done below: this just insures
126 ;;; access, etc.
127 
128 (defun object-mode-write-file (file-name &aux (file-object nil))
129        (protect
130          (setq file-object (open-file file-name 'write-force))
131          (object-mode-write (absolute-pathname (fobj-path file-object)))
132          &always
133          ;;restore access, bit-count set by "close" below
134          ;; this kludge necessary because "close" may also
135          ;; terminate the segment
136          (let ((new-fo (open-file file-name 'write nil)))
137               (when new-fo
138                     (setf (fobj-original-access new-fo)     ;copy access restoration info
139                           (fobj-original-access file-object))    ;to useful file object
140                     (close-file new-fo nil)       ;restore access
141                     (setf (fobj-original-access file-object) nil)))
142          (close-file file-object nil)))           ;clean up FCB
143 
144 ;;; Function to output an object-code buffer.  Besides the side
145 ;;; effect of writing out the buffer, returns 4 times the amount
146 ;;; of words in the file.
147 
148 (defun object-mode-write (file)
149        (save-excursion
150          (let ((fo (open file '(out ascii fixnum))))
151               (go-to-beginning-of-buffer)
152               (setq object-mode-count 0)
153               (minibuffer-remark "Writing...")
154               (let ((total-words 1))
155                    (catch
156                      (do () (())
157                          (object-mode-write-word fo)
158                          (setq total-words (1+ total-words)))
159                      object-mode-tag)
160                    (setq buffer-modified-flag nil
161                          fpathname (e_lap_$rtrim file))
162                    (minibuffer-remark "Written.")
163                    (close fo)
164                    (* 4. total-words)))))
165 
166 ;;; Reads the octal word at the point in the buffer, and moves
167 ;;; forward to the next group.
168 
169 (defun object-mode-get-octal ()
170        (with-mark beginning-of-word
171                   (forward-word)
172                   (prog1 (readlist
173                            (exploden
174                              (point-mark-to-string beginning-of-word)))
175                          (forward-char))))
176 
177 ;;; Function to output a single word of a file, given that we
178 ;;; are at the beginning of the representation of that word
179 ;;; in the buffer.
180 
181 (defun object-mode-write-word (file)
182        (and (zerop (cur-hpos)) (go-to-hpos 9.))
183        (out file
184             (+ (lsh (object-mode-get-octal) 27.)
185                (lsh (object-mode-get-octal) 18.)
186                (lsh (object-mode-get-octal) 9.)
187                (object-mode-get-octal)))
188        (forward-char) (forward-char)
189        (setq object-mode-count (1+ object-mode-count))
190        (cond ((= 3 object-mode-count)
191               (setq object-mode-count 0)
192               (next-line)))
193        (cond ((or (line-is-blank) (eolp) (looking-at " "))
194               (throw 'done object-mode-tag))))
195 
196 ;;; Insert letter in letters column.
197 
198 (defun object-mode-insert-letter (number)
199        (cond ((and (> number #o37) (< number #o177))
200               (insert-char (ItoC number)))
201              ('else (insert-char "."))))
202 
203 ;;; Give an error message stipulating that we're in
204 ;;; a non-editable column.
205 
206 (defun object-mode-bad-column ()
207        (display-error "Nothing to edit in this column."))
208 
209 ;;; Decides what type of column we are currently in:
210 ;;; 'numbers => the numeric kind of column.
211 ;;; 'letters => the alphabetic kind of column.
212 ;;; If in a bad column type, gives an error message.
213 
214 (defun object-mode-column-type ()
215        (let ((h (cur-hpos)))
216             (cond ((< h 9.) (object-mode-bad-column))
217                   ((or (> h 77.) (eolp)) (object-mode-bad-column))
218                   ((> h 63.)
219                    (cond ((member h '(68. 73.)) (object-mode-bad-column))
220                          ('else 'letters)))
221                   ((eq (curchar) '/ ) (object-mode-bad-column))
222                   ('else 'numbers))))
223 
224 ;;; Given that we are IN a numeric column, this updates this
225 ;;; group of numbers AND the associated ascii to the right.  We
226 ;;; assume that the new number has been inserted already.
227 
228 (defun object-mode-update-number ()
229        (save-excursion
230          (forward-char)
231          (backward-word)
232          (let ((h (- (cur-hpos) 9.))
233                (number (with-mark beginning-of-word
234                                   (forward-word)
235                                   (readlist
236                                     (exploden
237                                       (point-mark-to-string
238                                         beginning-of-word))))))
239               (go-to-hpos (+ 64.
240                              (* (// h 18.) 5.)
241                              (// (\ h 18.) 4.)))
242               (delete-char)
243               (object-mode-insert-letter number))))
244 
245 ;;; Given that we are IN a letter column, this updates this
246 ;;; letter AND the associated numbers to the right.  We
247 ;;; assume that the new letter has been inserted already.
248 
249 (defun object-mode-update-letter ()
250        (save-excursion
251          (let ((h (- (cur-hpos) 64.))
252                (number (CtoI (curchar))))
253               (delete-char)
254               (object-mode-insert-letter number)
255               (go-to-hpos (+ 9. (* 18. (// h 5.)) (* 4. (\ h 5))))
256               (delete-word)
257               (insert-string (pad-left-octal number)))))
258 
259 ;;; Replacement for self-insert.
260 
261 (defun object-mode-self-insert ()
262        (cond ((eq (object-mode-column-type) 'letters)
263               (let ((read-only-flag nil))
264                    (delete-char)
265                    (insert-char last-input-char)
266                    (backward-char)
267                    (object-mode-update-letter)))
268              ((member last-input-char '(/0 /1 /2 /3 /4 /5 /6 /7))
269               (let ((read-only-flag nil))
270                    (delete-char)
271                    (insert-char last-input-char)
272                    (backward-char)
273                    (object-mode-update-number)))
274              ('else
275                (display-error
276                  "You may only enter an octal number in this column.")))
277        (object-mode-forward-char))
278 
279 ;;; Replacement for quote-char.
280 
281 (defun object-mode-quote-char ()
282        (let ((last-input-char (make_atom (ItoC (get-char)))))
283             (object-mode-self-insert)))
284 
285 ;;; Save-same-file for object mode.
286 
287 (defcom object-mode-save-same-file
288         (check-minibuffer-file-command)
289         (or fpathname
290             (display-error "No default pathname for this buffer."))
291         (object-mode-write-file fpathname))
292 
293 ;;; write-file for object mode.
294 
295 (defcom object-mode-write-buffer
296         &args ((file &prompt "Write Object File: "
297                      &default &eval
298                      (or fpathname
299                          (display-error
300                            "No default pathname for this buffer."))))
301         (check-minibuffer-file-command)
302         (or file
303             (display-error "No default pathname for this buffer."))
304         (object-mode-write-file file))
305 
306 ;;; Command to read a file in in object mode.
307 
308 (defcom object-mode-find-file
309         &args ((name &prompt "Find Object File: "
310                      &default &eval
311                      (display-error "You must supply a pathname.")))
312         (let ((in (open-star-name-single name 'read))) ;Check existence/access
313              (close-file in nil)
314              (setq name (fobj-path in))
315              (unless (nullstringp (pn-component name))
316                      (report-error 'error_table_$archive_pathname))
317              (go-to-or-create-buffer
318                (object-mode-pick-buffer (pn-entry name)))
319              (object-mode-read-file (absolute-pathname name))
320              (object-mode)))
321 
322 ;;; Pick a good buffer to go to.
323 
324 (defun object-mode-pick-buffer (buffer)
325        (cond ((memq (make_atom buffer) known-buflist)
326               (ring-tty-bell)
327               (object-mode-pick-buffer
328                 (minibuf-response
329                   (catenate "Buffer " buffer
330                             " is already in use.  New buffer: ")
331                   NL)))
332              ('else (make_atom buffer))))
333 
334 ;;; Same as read-file for object-mode.  When using this,
335 ;;; we can assume you are in an object-mode buffer.
336 
337 (defcom object-mode-read-command
338         &prologue &eval (or (eq current-buffer-mode 'Object)
339                             (display-error "You must be in Object mode."))
340         &args ((name &prompt "Read Object File: "
341                      &default
342                      &eval (or fpathname
343                                (display-error
344                                  "No default pathname for this buffer."))))
345         (let ((in (open-star-name-single name 'read)))
346              (close-file in nil)
347              (setq name (fobj-path in))
348              (unless (nullstringp (pn-component name))
349                      (report-error 'error_table_$archive_pathname))
350              (object-mode-read-file (absolute-pathname name))))
351 
352 ;;; Go forward one character in an interesting way.
353 
354 (defcom object-mode-forward-char
355         (forward-char)
356         (let ((h (cur-hpos)))
357              (cond ((< h 60.) (skip-over-whitespace-in-line))
358                    ((= h 60.) (next-line) (go-to-hpos 9.))
359                    ((member h '(68. 73.)) (forward-char))
360                    ((eolp) (next-line) (go-to-hpos 64.)))))
361 
362 ;;; Instate object mode.
363 
364 (defun object-mode ()
365        (setq current-buffer-mode 'Object)
366        (setq read-only-flag 't)
367        (map-over-emacs-commands
368           '(lambda (symbol function junk) junk
369                    (and (eq function 'self-insert)
370                         (set-key symbol 'object-mode-self-insert)))
371           ())
372        (set-key "^M"    'object-mode-self-insert)
373        (set-key "^Q"    'object-mode-quote-char)
374        (set-key "^X-^S" 'object-mode-save-same-file)
375        (set-key "^X-^W" 'object-mode-write-buffer)
376        (set-key "^X-^R" 'object-mode-read-command))