lispdoc: implemented the whole URI syntax; updated URIs in all docstrings to be writt...
[com-informatimago:com-informatimago.git] / common-lisp / ed / ed.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               ed.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;
9 ;;;;    See defpackage documentation string.
10 ;;;;
11 ;;;;AUTHORS
12 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
13 ;;;;MODIFICATIONS
14 ;;;;    2012-03-31 <PJB> Made a few corrections.
15 ;;;;    2003-12-19 <PJB> Created.
16 ;;;;BUGS
17 ;;;;
18 ;;;;    Not complete.
19 ;;;;    (Still waiting on regexp package...).
20 ;;;;
21 ;;;;    In: 1,20!(do-something-with *input*)
22 ;;;;    *input* is not bound to the 20 lines, and the output is not
23 ;;;;    *inserted in the buffer.
24 ;;;; 
25 ;;;;LEGAL
26 ;;;;    AGPL3
27 ;;;;    
28 ;;;;    Copyright Pascal J. Bourguignon 2003 - 2012
29 ;;;;    
30 ;;;;    This program is free software: you can redistribute it and/or modify
31 ;;;;    it under the terms of the GNU Affero General Public License as published by
32 ;;;;    the Free Software Foundation, either version 3 of the License, or
33 ;;;;    (at your option) any later version.
34 ;;;;    
35 ;;;;    This program is distributed in the hope that it will be useful,
36 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
37 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
38 ;;;;    GNU Affero General Public License for more details.
39 ;;;;    
40 ;;;;    You should have received a copy of the GNU Affero General Public License
41 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
42 ;;;;****************************************************************************
43
44 (in-package "COMMON-LISP-USER")
45 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.ED.ED"
46   (:documentation
47    "
48 This package exports an implementation of the COMMON-LISP ED function
49 following the user manual of ed(1).
50
51
52 ed(1) in COMMON-LISP.
53
54 Real men do it with magnets.  ed is for girly men.
55
56 This is a clone of the unix ed(1) editor written in pure Common-Lisp.
57 Since Common-Lisp does not define any process management functions,
58 all !command forms are taken as Lisp forms instead of sh(1) commands.
59 These forms are executed within a (LAMBDA (*INPUT*) command) with
60 the *INPUT* argument bound to a mutable list of inmutable input strings,
61 one per line.  The result of the returning form in command must be
62 a list of string, the list of resulting lines to be inserted into the
63 buffer or to be printed on the terminal.
64
65 For the rest, the aim is to be 100% user-interface compatible with ed(1).
66
67 Ed, man! !man ed: <http://www.gnu.org/fun/jokes/ed.msg.html>
68
69
70 Can you imagine that some Common-Lisp implementations DON'T provide
71 any editor (in conformity with the Common-Lisp specifications)?
72 Not complete (waiting for a REGEXP package). But otherwise
73 functional enough. 
74
75
76
77 License:
78
79     AGPL3
80     
81     Copyright Pascal J. Bourguignon 2003 - 2012
82     
83     This program is free software: you can redistribute it and/or modify
84     it under the terms of the GNU Affero General Public License as published by
85     the Free Software Foundation, either version 3 of the License, or
86     (at your option) any later version.
87     
88     This program is distributed in the hope that it will be useful,
89     but WITHOUT ANY WARRANTY; without even the implied warranty of
90     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
91     GNU Affero General Public License for more details.
92     
93     You should have received a copy of the GNU Affero General Public License
94     along with this program.
95     If not, see <http://www.gnu.org/licenses/>
96
97 ")
98   (:use "COMMON-LISP")
99   (:shadow "ED")
100   (:export "ED"))
101 (in-package "COM.INFORMATIMAGO.COMMON-LISP.ED.ED")
102
103
104 (eval-when (:compile-toplevel :load-toplevel :execute)
105   (defconstant +debug+       t)
106   (defparameter *show-debug* nil))
107
108
109 (defmacro dbg (&body body)
110   (when +debug+ 
111     `(when *show-debug* (let ((*standard-output* *trace-output*)) ,@body))))
112
113 ;;(WHEN +DEBUG+
114 ;;(shadow 'handler-case)
115 ;;(defmacro handler-case (form &rest args) form))
116
117
118
119 ;;--------
120 ;; buffer:
121 ;;--------
122
123 (defstruct buffer
124   (path          nil)
125   (lines         '(0)) ; (index-of-current-line . lines)
126   (marks         '( )) ; ((ch . linum) ...)
127   (old-lines     '(0)) ; (index-of-current-line . lines)
128   (old-marks     '( )) ; ((ch . linum) ...)
129   (cut-lines     '( )) ; (lines ...)
130   (show-errors   nil)
131   (got-error     nil)
132   (last-error    "")
133   (show-prompt   nil)
134   (prompt-string "")
135   (command       nil)
136   (modified      nil)
137   (print         nil)
138   (quit          nil))
139
140 ;; (setq b (buffer-read "~/test.txt"))
141
142 (defmacro toggle (place &environment env)
143   (multiple-value-bind (vars vals stores setter getter) (get-setf-expansion place env)
144     `(let* (,@(mapcar (function list) vars vals)
145             (,(car stores) ,getter))
146        (prog1
147            (setq ,(car stores) (not ,(car stores)))
148          ,setter))))
149
150
151 ;;-------
152 ;; lines:
153 ;;-------
154
155 (defun (setf buffer-current-linum) (new-linum buffer) (setf (car (buffer-lines buffer)) new-linum))
156 (defun buffer-current-linum  (buffer) (car (buffer-lines buffer)))
157 (defun buffer-length         (buffer) (length (cdr (buffer-lines buffer))))
158 (defun buffer-nth-line (buffer linum) (car (buffer-line-cons buffer linum)))
159
160 (defun buffer-line-cons (buffer linum)
161   "Return the cons cells where the line LINUM of the BUFFER is stored."
162   (if (< linum 0)
163       nil
164       (nthcdr linum (buffer-lines buffer))))
165
166 ;;-------
167 ;; marks:
168 ;;-------
169
170 (defun buffer-set-mark (buffer ch linum)
171   (let ((ass (assoc ch (buffer-marks buffer))))
172     (if ass
173         (setf (cdr ass) linum)
174         (push (cons ch linum) (buffer-marks buffer))))
175   (values))
176
177
178 (defun buffer-get-mark (buffer ch)
179   (cdr (assoc ch (buffer-marks buffer))))
180
181
182 (defun buffer-offset-marks (buffer from offset)
183   (if (< offset 0)
184       (let ((mindel (+ from offset)))
185         (setf (buffer-marks buffer)
186               (mapcan (lambda (ass)
187                         (cond
188                           ((< (cdr ass) mindel) (list ass))
189                           ((< (cdr ass) from)   nil)
190                           (t  (incf (cdr ass) offset) (list ass))))
191                       (buffer-marks buffer))))
192       (map nil (lambda (ass) (when (<= from (cdr ass)) (incf (cdr ass) offset)))
193            (buffer-marks buffer))))
194
195
196 (defun copy-marks (marks)
197   (mapcar (lambda (ass) (cons (car ass) (cdr ass))) marks))
198
199
200 ;;----------------
201 ;; error messages:
202 ;;----------------
203
204 (defun buffer-clear-error (buffer)
205   (setf (buffer-got-error buffer) nil))
206
207
208 (defun buffer-set-error (buffer message)
209   (setf (buffer-last-error buffer) message
210         (buffer-got-error  buffer) t))
211
212
213 ;;-------------
214 ;; undo buffer:
215 ;;-------------
216
217 (defun buffer-save-undo (buffer)
218   (setf (buffer-modified buffer) t)
219   (setf (buffer-old-marks buffer) (copy-marks (buffer-marks buffer))
220         (buffer-old-lines buffer) (copy-seq (buffer-lines buffer))))
221
222
223 (defun buffer-swap-undo (buffer)
224   (psetf (buffer-old-marks buffer) (buffer-marks buffer)
225          (buffer-marks buffer)     (buffer-old-marks buffer)
226          (buffer-old-lines buffer) (buffer-lines buffer)
227          (buffer-lines buffer)     (buffer-old-lines buffer)))
228
229
230 (defun buffer-erase (buffer)
231   ;; no undo!
232   (setf (buffer-lines     buffer) '(0)
233         (buffer-marks     buffer) nil
234         (buffer-old-lines buffer) '(0)
235         (buffer-old-marks buffer) nil
236         (buffer-cut-lines buffer) nil
237         (buffer-modified  buffer) t))
238
239
240
241 (defun buffer-read (path)
242   (let ((buffer (make-buffer :path path)))
243     (do-read buffer path 0)
244     buffer))
245
246
247 (defun buffer-from-string (text)
248   (let ((buffer(make-buffer)))
249     (do-paste buffer 0
250               (do ((newline (format nil "~%"))
251                    (lines ()) (position 0) (nextpos 0))
252                   ((>= nextpos (length text)) (nreverse lines))
253                 (setq position (search newline text :start2 nextpos))
254                 (if position
255                     (progn
256                       (push (subseq text nextpos position) lines)
257                       (setq nextpos (+ position (length newline))))
258                     (progn
259                       (push (subseq text nextpos) lines)
260                       (setq nextpos (length text))))))
261     buffer))
262
263
264
265 (defun limit (value min max)
266   (if (<= min value max)
267       value
268       nil))
269
270
271 (defun address->linum (buffer address &optional (min 1))
272   (cond
273     ((null address) nil)
274     ((eq address :curr)  (buffer-current-linum buffer))
275     ((eq address :first) 1)
276     ((eq address :last)  (buffer-length buffer))
277     ((eq address :next)  (limit (1+ (buffer-current-linum buffer))
278                                 1 (buffer-length buffer)))
279     ((eq address :prev)  (limit (1- (buffer-current-linum buffer))
280                                 min (buffer-length buffer)))
281     ((not (consp address)) nil)
282     ((eq (car address) :next) (limit (+ (buffer-current-linum buffer)
283                                         (cdr address))
284                                      1 (buffer-length buffer)))
285     ((eq (car address) :prev) (limit (- (buffer-current-linum buffer)
286                                         (cdr address))
287                                      min (buffer-length buffer)))
288     ((eq (car address) :linum) (limit (cdr address)
289                                       min (buffer-length buffer)))
290     ((eq (car address) :mark) (limit (buffer-get-mark buffer (cdr address))
291                                      1 (buffer-length buffer)))
292     ((eq (car address) :regexp)
293      ;; TODO: regexp not implemented yet.
294      (format *terminal-io* "REGEXP NOT IMPLEMENTED YET.~%"))))
295
296
297 (defmacro with-addresses ((buffer . addresses) &body body)
298   `(let ,(mapcar (lambda (vam)
299                    `(,(first vam)
300                       (address->linum ,buffer ,(second vam) ,(third vam))))
301                  addresses)
302      (if (or ,@(mapcar (lambda (vam) `(null ,(first vam))) addresses)
303              ,@(when (<= 2 (length addresses))
304                      `((< ,(first (second addresses))
305                           ,(first (first  addresses))))))
306          (buffer-set-error ,buffer "Invalid address")
307          (progn ,@body))))
308
309
310 (defmacro unless-modified (buffer &body body)
311   `(if (buffer-modified ,buffer)
312        (progn
313          (setf (buffer-modified ,buffer) nil)
314          (buffer-set-error ,buffer "Warning: file modified"))
315        (progn
316          ,@body)))
317
318
319 ;; (progn (PJB-CL+INDENT with-addresses 1)(PJB-CL+INDENT unless-modified 1))
320
321 (defun do-insert (buffer linum)
322   (dbg (format t "DO-INSERT(~S ~S) ~%" "buffer" linum))
323   (do ((place (buffer-line-cons buffer linum) (cdr place))
324        (line  (read-line *terminal-io* nil ".")
325               (read-line *terminal-io* nil "."))
326        (curr  linum (1+ curr)))
327       ((string= line ".")
328        (progn
329          (setf (buffer-current-linum buffer) curr)
330          (buffer-offset-marks buffer linum (- curr linum))))
331     (setf (cdr place) (cons line (cdr place)))))
332
333
334 (defun do-paste (buffer linum new-lines)
335   (dbg (format t "DO-PASTE(~S ~S [~D lines]) ~%"
336                "buffer" linum (length new-lines)))
337   (let* ((insert-point (buffer-line-cons buffer linum))
338          (after        (cdr insert-point)))
339     (setf (buffer-current-linum buffer) (+ linum (length new-lines)))
340     (setf (cdr insert-point) new-lines)
341     (setf (cdr (last new-lines)) after)))
342
343
344 (defun do-cut (buffer from last)
345   "
346 RETURN: The list of cut lines.
347 "
348   (dbg (format t "DO-CUT(~S ~S ~S) ~%" "buffer" from last))
349   (let* ((delete-point (buffer-line-cons buffer (1- from)))
350          (after-point  (buffer-line-cons buffer  last))
351          (result       (cdr delete-point)))
352     (setf (buffer-current-linum buffer)
353           (if (null (cdr after-point)) from (1+ from)))
354     (setf (cdr delete-point) (cdr after-point)
355           (cdr after-point) nil)
356     (buffer-offset-marks buffer from (- last from -1))
357     result))
358
359
360 (defun do-print-lines (buffer curr last func)
361   (dbg (format t " DO-PRINT-LINES(~S ~S ~S [a function]) ~%" "buffer" curr last))
362   (setf (buffer-print buffer) nil)
363   (do* ((curr curr (1+ curr))
364         (lines (buffer-line-cons buffer curr) (cdr lines)))
365        ((> curr last)
366         (setf (buffer-current-linum buffer) last))
367     (funcall func curr (car lines))))
368
369
370 (defun do-write (buffer path mode from last)
371   (dbg (format t "DO-WRITE(~S ~S ~S ~S ~S) ~%" "buffer" path mode from last))
372   (handler-case
373       (with-open-file (output path :direction :output :if-exists mode
374                               :if-does-not-exist :create)
375         (do ((line (buffer-line-cons buffer from) (cdr line))
376              (curr from (1+ curr)))
377             ((> curr last))
378           (format output "~A~%" (car line))))
379     (error (err) (buffer-set-error buffer (format nil "~S" err)))))
380
381
382 (defun do-read (buffer path linum)
383   (dbg (format t "DO-READ(~S ~S ~S) ~%" "buffer" path linum))
384   (handler-case
385       (do-paste buffer linum
386                 (with-open-file (input path :direction :input
387                                        :if-does-not-exist :error)
388                   (do ((lines '() (cons line lines))
389                        (line t))
390                       ((null line) (nreverse (cdr lines)))
391                     (setf line (read-line input nil nil)))))
392     (error (err) (buffer-set-error buffer (format nil "~S" err)))))
393
394
395 (defun filter-command-output (output)
396   (if (and (listp output) (every (function stringp) output))
397       output
398       (list (format nil "~S" output))))
399
400
401 ;; (defmacro hc (form &rest rest) form)
402
403 (defun do-command (buffer &key (input nil) (output :print))
404   (dbg (format t "DO-COMMAND(~S ~S ~S) ~%" "buffer" input output))
405   (if (buffer-command buffer)
406       (handler-case
407           (progn
408             (format *terminal-io* "~A~%" (buffer-command buffer))
409             (let* ((*package* (find-package "COM.INFORMATIMAGO.COMMON-LISP.ED.ED"))
410                    (results   (eval `((lambda (*input*)
411                                         (declare (ignorable *input*))
412                                         ,(read-from-string 
413                                           (format nil "(progn  ~A)"
414                                                   (buffer-command buffer))))
415                                       (list ,@input)))))
416               (case output
417                 ((:print)
418                  (map nil (lambda (line) (format *terminal-io* "~A~%" line))
419                       (filter-command-output results))
420                  (format *terminal-io* "!~%")
421                  (values))
422                 ((:result)
423                  (format *terminal-io* "!~%")
424                  results)
425                 (otherwise
426                  (buffer-set-error buffer "Internal error: DO-COMMAND")
427                  (values)))))
428         (error (err)
429           (buffer-set-error buffer (format nil "~S" err))
430           (values)))
431       (progn
432         (buffer-set-error buffer "No previous command")
433         (values))))
434
435
436 (defun cmd-comment (buffer from to arg)
437   (declare (ignore from to arg))
438   (dbg (format t "CMD-COMMENT: ~%"))
439   ;; (.,.)#  Begins a comment;  the rest of the line, up to a newline,
440   ;;         is ignored.  If a line address followed by a semicolon is
441   ;;         given,  then  the current address is set to that address.
442   ;;         Otherwise, the current address is unchanged.
443   (setf (buffer-print buffer) nil))
444
445
446 (defun cmd-append (buffer from to arg)
447   (declare (ignore from arg))
448   (dbg (format t "CMD-APPEND: ~%"))
449   ;; (.)a    Appends text to the  buffer  after  the  addressed  line,
450   ;;         which  may  be  the address 0 (zero).  Text is entered in
451   ;;         input mode.  The current address  is  set  to  last  line
452   ;;         entered.
453   (with-addresses (buffer (linum to 0))
454     (buffer-save-undo buffer)
455     (do-insert buffer linum)))
456
457
458 (defun cmd-insert (buffer from to arg)
459   (declare (ignore from arg))
460   (dbg (format t "CMD-INSERT: ~%"))
461   ;; (.)i    Inserts text in the buffer before the current line.  Text
462   ;;         is entered in input mode.  The current address is set  to
463   ;;         the last line entered.
464   (with-addresses (buffer (linum to 1))
465     (buffer-save-undo buffer)
466     (do-insert buffer (1- linum))))
467
468
469 (defun cmd-delete-lines (buffer from to arg)
470   (declare (ignore arg))
471   (dbg (format t "CMD-DELETE-LINES: ~%"))
472   ;; (.,.)d  Deletes the addressed lines from the buffer.  If there is
473   ;;         a  line after the deleted range, then the current address
474   ;;         is set to this line. Otherwise the current address is set
475   ;;         to the line before the deleted range.
476   (with-addresses (buffer (curr from 1) (last to 1))
477     (buffer-save-undo buffer)
478     (setf (buffer-cut-lines buffer) (do-cut buffer curr last))))
479
480                   
481 (defun cmd-copy (buffer from to arg)
482   (declare (ignore arg))
483   (dbg (format t "CMD-COPY: ~%"))
484   ;; (.,.)y  Copies (yanks) the addressed lines  to  the  cut  buffer.
485   ;;         The  cut  buffer  is  overwritten by subsequent `y', `s',
486   ;;         `j', `d',  or  `c'  commands.   The  current  address  is
487   ;;         unchanged.
488   ;; no undo
489   (with-addresses (buffer (curr from 1) (last to 1))
490     ;; We don't need to make copies of the line string
491     ;; because they're considered immutable.
492     ;; When edited (changed, substituted),
493     ;; a new copy replaces the old one.
494     (setf (buffer-cut-lines buffer)
495           (subseq (buffer-lines buffer) curr (1+ last)))))
496
497  
498 (defun cmd-paste (buffer from to arg)
499   (declare (ignore from arg))
500   (dbg (format t "CMD-PASTE: ~%"))
501   ;; (.)x    Copies (puts) the contents of the cut buffer to after the
502   ;;         addressed  line.   The current address is set to the last
503   ;;         line copied.
504   (with-addresses (buffer (curr to 0))
505     (buffer-save-undo buffer)
506     (do-paste buffer curr (copy-seq (buffer-cut-lines buffer)))))
507
508
509 (defun cmd-undo (buffer from to arg)
510   (declare (ignore from to arg))
511   (dbg (format t "CMD-UNDO: ~%"))
512   ;; u       Undoes the last command and restores the current  address
513   ;;         to  what  it was before the command.  The global commands
514   ;;         `g', `G', `v', and `V'.  are treated as a single  command
515   ;;         by undo.  `u' is its own inverse.
516   (buffer-swap-undo buffer))
517
518
519
520 (defun cmd-copy-lines (buffer from to arg)
521   (dbg (format t "CMD-COPY-LINES: ~%"))
522   ;; (.,.)t(.)
523   ;;         Copies (i.e., transfers) the addressed lines to after the
524   ;;         right-hand destination address, which may be the  address
525   ;;         0  (zero).   The  current address is set to the last line
526   ;;         copied.
527   (with-addresses (buffer (curr from 1) (last to 1) (target arg 0))
528     (buffer-save-undo buffer)
529     (do-paste buffer arg (subseq (buffer-lines buffer) curr (1+ last)))))
530
531
532 (defun cmd-move-lines (buffer from to arg)
533   (dbg (format t "CMD-MOVE-LINES: ~%"))
534   ;; (.,.)m(.)
535   ;;         Moves lines in the buffer.  The addressed lines are moved
536   ;;         to after the right-hand destination address, which may be
537   ;;         the address 0 (zero).  The current address is set to  the
538   ;;         last line moved.
539   (with-addresses (buffer (curr from 1) (last to 1) (target arg 0))
540     (buffer-save-undo buffer)
541     (do-paste buffer arg (do-cut buffer curr last))))
542
543
544 (defun cmd-change-lines (buffer from to arg)
545   (dbg (format t "CMD-CHANGE-LINES: ~%"))
546   ;; (.,.)c  Changes  lines  in  the  buffer.  The addressed lines are
547   ;;         deleted from the buffer, and text is  appended  in  their
548   ;;         place.   Text  is  entered  in  input  mode.  The current
549   ;;         address is set to last line entered.
550   (with-addresses (buffer (curr from 1) (last to 1) (target arg 0))
551     (buffer-save-undo buffer)
552     (setf (buffer-cut-lines buffer) (do-cut buffer curr last))
553     (do-insert buffer curr)))
554
555
556 (defun cmd-join-lines (buffer from to arg)
557   (declare (ignore arg))
558   (dbg (format t "CMD-JOIN-LINES: ~%"))
559   ;; (.,.+1)j
560   ;;         Joins  the  addressed  lines.   The  addressed  lines are
561   ;;         deleted from the buffer and replaced  by  a  single  line
562   ;;         containing their joined text.  The current address is set
563   ;;         to the resultant line.
564   (with-addresses (buffer (curr from 1) (last to 1))
565     (buffer-save-undo buffer)
566     (setf (buffer-cut-lines buffer) (do-cut buffer curr last))
567     (do-paste buffer (1- curr)
568               (apply (function concatenate) 'string
569                      (buffer-cut-lines buffer)))))
570
571
572 (defun cmd-mark (buffer from to arg)
573   (declare (ignore from))
574   (dbg (format t "CMD-MARK: ~%"))
575   ;; (.)klc  Marks a line with a lower case letter lc.  The  line  can
576   ;;         then  be  addressed as 'lc (i.e., a single quote followed
577   ;;         by lc ) in subsequent commands.  The mark is not  cleared
578   ;;         until the line is deleted or otherwise modified.
579   (with-addresses (buffer (curr to 1))
580     (buffer-set-mark buffer arg curr)))
581
582
583 (defun cmd-print-line-number (buffer from to arg)
584   (declare (ignore from arg))
585   (dbg (format t "CMD-PRINT-LINE-NUMBER: ~%"))
586   ;; ($)=    Prints the line number of the addressed line.
587   (with-addresses (buffer (curr to 1))
588     (format *terminal-io* "~D~%" curr)))
589
590
591 (defun cmd-scroll-lines (buffer from to arg)
592   (declare (ignore from arg))
593   (dbg (format t "CMD-SCROLL-LINES: ~%"))
594   ;; (.+1)zn Scrolls n lines at a time starting at addressed line.  If
595   ;;         n is not specified, then the current window size is used.
596   ;;         The current address is set to the last line printed.
597   (with-addresses (buffer (curr to 1))
598     ;; TODO: IMPLEMENT SCROLL!
599     (do-print-lines buffer curr (buffer-length buffer)
600                     (lambda (linum line)
601                       (declare (ignore linum))
602                       (format *terminal-io* "~A~%" line))) ))
603
604
605 (defun cmd-print-lines (buffer from to arg)
606   (declare (ignore arg))
607   (dbg (format t "CMD-PRINT-LINES: ~%"))
608   ;;     (.+1)newline
609   ;;             Prints the addressed line, and sets the  current  address
610   ;;             to that line.
611   ;;     (.,.)p  Prints the addressed lines.    If invoked from  a  termi-
612   ;;             nal, ed pauses at the end of each page until a newline is
613   ;;             entered.  The current address is set  to  the  last  line
614   ;;             printed.
615   (with-addresses (buffer (curr from 1) (last to 1))
616     (do-print-lines buffer curr last
617                     (lambda (linum line)
618                       (declare (ignore linum))
619                       (format *terminal-io* "~A~%" line)))))
620
621
622 (defun cmd-print-lines-and-numbers (buffer from to arg)
623   (declare (ignore arg))
624   (dbg (format t "CMD-PRINT-LINES-AND-NUMBERS: ~%"))
625   ;;     (.,.)n  Prints the addressed lines along with their line numbers.
626   ;;             The current address is set to the last line printed.
627   ;;
628   (with-addresses (buffer (curr from 1) (last to 1))
629     (do-print-lines buffer curr last
630                     (lambda (linum line)
631                       (format *terminal-io* "~6D  ~A~%" linum line)))))
632
633    
634 (defun cmd-print-lines-unambiguously (buffer from to arg)
635   (declare (ignore arg))
636   (dbg (format t "CMD-PRINT-LINES-UNAMBIGUOUSLY: ~%"))
637   ;;     (.,.)l  Prints  the  addressed  lines  unambiguously.  If invoked
638   ;;             from a terminal, ed pauses at the end of each page  until
639   ;;             a  newline is entered.  The current address is set to the
640   ;;             last line printed.
641   (with-addresses (buffer (curr from 1) (last to 1))
642     (do-print-lines
643         buffer curr last
644         (lambda (linum line)
645           (declare (ignore linum))
646           (do ((i 0 (1+ i))
647                (ch))
648               ((>= i (length line)) (format *terminal-io* "$~%"))
649             (setq ch (char line i))
650             (if (graphic-char-p ch)
651                 (format *terminal-io* "~C" ch)
652                 (let ((ass (assoc (char-code ch)
653                                   '((7 . "a") (8 . "b") (9 . "t")
654                                     (10 . "l") (11 . "v") (12 . "f")
655                                     (13 . "r")))))
656                   (if ass
657                       (format *terminal-io* "\\~A" (cdr ass))
658                       (format *terminal-io* "\\~3,'0O" (char-code ch))))))))))
659
660
661 (defun cmd-substitute (buffer from to arg)
662   (declare (ignore buffer from to arg)) ;; TODO: implement this function.
663   (dbg (format t "CMD-SUBSTITUTE: ~%"))
664   ;; (.,.)s/re/replacement/
665   ;; (.,.)s/re/replacement/g
666   ;; (.,.)s/re/replacement/n
667   ;;         Replaces  text  in the addressed lines matching a regular
668   ;;         expression re with replacement.   By  default,  only  the
669   ;;         first  match  in  each  line  is  replaced.   If  the `g'
670   ;;         (global)  suffix  is  given,  then  every  match  to   be
671   ;;         replaced.   The  `n' suffix, where n is a postive number,
672   ;;         causes only the nth match to be replaced.  It is an error
673   ;;         if no substitutions are performed on any of the addressed
674   ;;         lines.   The  current  address  is  set  the  last   line
675   ;;         affected.
676   ;;
677   ;;         re  and  replacement  may  be  delimited by any character
678   ;;         other than space and newline (see the `s' command below).
679   ;;         If one or two of the last delimiters is omitted, then the
680   ;;         last line affected is printed as though the print  suffix
681   ;;         `p' were specified.
682   ;;
683   ;;         An  unescaped  `&' in replacement is replaced by the cur-
684   ;;         rently matched text.  The character sequence `\m',  where
685   ;;         m  is a number in the range [1,9], is replaced by the mth
686   ;;         backreference  expression  of  the  matched   text.    If
687   ;;         replacement  consists  of  a single `%', then replacement
688   ;;         from the last substitution  is  used.   Newlines  may  be
689   ;;         embedded  in replacement if they are escaped with a back-
690   ;;         slash (\).
691   ;;
692   ;; (.,.)s  Repeats the last substitution.  This form of the `s' com-
693   ;;         mand  accepts  a  count suffix `n', or any combination of
694   ;;         the characters `r', `g', and `p'.  If a count suffix  `n'
695   ;;         is  given,  then only the nth match is replaced.  The `r'
696   ;;         suffix causes the regular expression of the  last  search
697   ;;         to  be used instead of the that of the last substitution.
698   ;;         The `g' suffix toggles the global suffix of the last sub-
699   ;;         stitution.   The  `p'  suffix toggles the print suffix of
700   ;;         the last substitution The current address is set  to  the
701   ;;         last line affected.
702   (format *terminal-io* "NOT IMPLEMENTED YET.~%"))
703     
704         
705 (defun cmd-edit-matching (buffer from to arg)
706   (declare (ignore buffer from to arg)) ;; TODO: implement this function.
707   (dbg (format t "CMD-EDIT-MATCHING: ~%"))
708   ;; (1,$)g/re/command-list
709   ;;         Applies  command-list  to  each  of  the  addressed lines
710   ;;         matching a regular expression re.  The current address is
711   ;;         set  to the line currently matched before command-list is
712   ;;         executed.  At the end of the  `g'  command,  the  current
713   ;;         address is set to the last line affected by command-list.
714   ;;
715   ;;         Each command in command-list must be on a separate  line,
716   ;;         and  every line except for the last must be terminated by
717   ;;         a backslash (\).  Any commands are  allowed,  except  for
718   ;;         `g',  `G', `v', and `V'.  A newline alone in command-list
719   ;;         is equivalent to a `p' command.
720   ;;
721   (format *terminal-io* "NOT IMPLEMENTED YET.~%"))
722
723
724 (defun cmd-edit-not-matching (buffer from to arg)
725   (declare (ignore buffer from to arg)) ;; TODO: implement this function.
726   (dbg (format t "CMD-EDIT-NOT-MATCHING: ~%"))
727   ;; (1,$)v/re/command-list
728   ;;         Applies  command-list  to each of the addressed lines not
729   ;;         matching a regular expression re.  This is similar to the
730   ;;         `g' command.
731   ;;
732   (format *terminal-io* "NOT IMPLEMENTED YET.~%"))
733
734
735 (defun cmd-user-edit-matching (buffer from to arg)
736   (declare (ignore buffer from to arg)) ;; TODO: implement this function.
737   (dbg (format t "CMD-USER-EDIT-MATCHING: ~%"))
738   ;; (1,$)G/re/
739   ;;         Interactively edits the addressed lines matching a  regu-
740   ;;         lar  expression  re.  For each matching line, the line is
741   ;;         printed, the current address is  set,  and  the  user  is
742   ;;         prompted  to enter a command-list.  At the end of the `G'
743   ;;         command, the current address is  set  to  the  last  line
744   ;;         affected by (the last) command-list.
745   ;;
746   ;;         The format of command-list is the same as that of the `g'
747   ;;         command.  A newline alone acts as a null command list.  A
748   ;;         single `&' repeats the last non-null command list.
749   (format *terminal-io* "NOT IMPLEMENTED YET.~%"))
750
751
752 (defun cmd-user-edit-not-matching (buffer from to arg)
753   (declare (ignore buffer from to arg)) ;; TODO: implement this function.
754   (dbg (format t "CMD-USER-EDIT-NOT-MATCHING: ~%"))
755   ;; (1,$)V/re/
756   ;;         Interactively  edits  the  addressed lines not matching a
757   ;;         regular expression re.  This is similar to the  `G'  com-
758   ;;         mand.
759   (format *terminal-io* "NOT IMPLEMENTED YET.~%"))
760
761
762 (defun file-or-command-arg (arg)
763   "
764   -->  :empty 
765   -->  :path           ; path    ; exists (t/nil)
766   -->  :command        ; command
767   -->  :command-append ; command
768   -->  :invalid        ; error-message
769 "
770   (if (string= "" arg)
771       (values :empty)
772       (progn
773         (let ((pos (skip-spaces arg)))
774           (when (and pos (< 0 pos)) (setq arg (subseq arg pos))))
775         (cond
776           ((or (string= "" arg)
777                (handler-case (prog1 nil (probe-file arg)) (error nil t)))
778            (values :invalid  "Invalid filename"))
779           ((and (<= 2 (length arg)) (string= "!!" arg :end2 2))
780            (values :command-append (subseq arg 2)))
781           ((and (<= 1 (length arg)) (string= "!"  arg :end2 1))
782            (values :command (subseq arg 1)))
783           (t
784            (values :path arg (probe-file arg)))))))
785
786
787
788 (defun cmd-write-or-append (buffer from to arg mode)
789   (with-addresses (buffer (curr from 1) (last to 1))
790     (multiple-value-bind (kind path exists) (file-or-command-arg arg)
791       (declare (ignore exists))
792       (case kind
793         ((:empty)
794          (if (buffer-path buffer)
795              (do-write buffer (buffer-path buffer) mode curr last)
796              (buffer-set-error buffer "No current filename")))
797         ((:path)
798          (unless (buffer-path buffer)
799            (setf (buffer-path buffer) path))
800          (do-write buffer path mode curr last))
801         ((:comand)
802          (setf (buffer-command buffer) path)
803          (do-command buffer
804            :input (subseq (buffer-lines buffer) curr (1+ last))))
805         ((:comand-append)
806          (setf (buffer-command buffer)
807                (concatenate 'string (buffer-command buffer) path))
808          (do-command buffer
809            :input (subseq (buffer-lines buffer) curr (1+ last))))
810         ((:invalid) (buffer-set-error buffer path))
811         (otherwise
812          (buffer-set-error buffer "Internal error: FILE-OR-COMMAND-ARG"))))))
813
814
815 (defun cmd-append-file (buffer from to arg)
816   (dbg (format t "CMD-APPEND-FILE: ~%"))
817   ;; (1,$)W file
818   ;;         Appends  the addressed lines to the end of file.  This is
819   ;;         similar to the `w' command, expect that the previous con-
820   ;;         tents  of  file is not clobbered.  The current address is
821   ;;         unchanged.
822   (cmd-write-or-append buffer from to arg :append))
823
824
825 (defun cmd-write-file (buffer from to arg)
826   (dbg (format t "CMD-WRITE-FILE: ~%"))
827   ;; (1,$)w file
828   ;;         Writes  the  addressed  lines to file.  Any previous con-
829   ;;         tents of file is lost without warning.  If  there  is  no
830   ;;         default  filename,  then  the  default filename is set to
831   ;;         file, otherwise it is unchanged.  If no filename is spec-
832   ;;         ified,  then  the  default filename is used.  The current
833   ;;         address is unchanged.
834   ;;
835   ;; (1,$)w !command
836   ;;         Writes  the  addressed  lines  to  the  standard input of
837   ;;         `!command', (see the !command below).  The default  file-
838   ;;         name and current address are unchanged.
839   (cmd-write-or-append buffer from to arg :supersede))
840
841
842 (defun cmd-write-file-quit (buffer from to arg)
843   (dbg (format t "CMD-WRITE-FILE-QUIT: ~%"))
844   ;; (1,$)wq file
845   ;;         Writes the addressed lines to file, and then  executes  a
846   ;;         `q' command.
847   ;;
848   (cmd-write-file buffer from to arg)
849   (unless (buffer-got-error buffer)
850     (cmd-quit buffer from to arg)))
851
852
853 (defun cmd-edit-or-read (buffer arg linum)
854   "
855 LINUM:  NIL ==> Edit, NUMBERP ==> Read
856 "
857   (multiple-value-bind (kind path exists) (file-or-command-arg arg)
858     (declare (ignore exists))
859     (case kind
860       ((:empty)
861        (if (buffer-path buffer)
862            (progn
863              (unless linum (buffer-erase buffer))
864              (do-read buffer (buffer-path buffer) (or linum 0)))
865            (buffer-set-error buffer "No current filename")))
866       ((:path)
867        (setf (buffer-path buffer) path)
868        (unless linum (buffer-erase buffer))
869        (do-read buffer path (or linum 0)))
870       ((:comand)
871        (setf (buffer-command buffer) path)
872        (unless linum (buffer-erase buffer))
873        (do-paste buffer (or linum 0)
874                  (filter-command-output (do-command buffer :output :result))))
875       ((:comand-append)
876        (setf (buffer-command buffer)
877              (concatenate 'string (buffer-command buffer) path))
878        (unless linum (buffer-erase buffer))
879        (do-paste buffer (or linum 0)
880                  (filter-command-output (do-command buffer :output :result))))
881       ((:invalid) (buffer-set-error buffer path))
882       (otherwise
883        (buffer-set-error buffer "Internal error: FILE-OR-COMMAND-ARG")))))
884
885
886 (defun cmd-read-file (buffer from to arg)
887   (declare (ignore from))
888   (dbg (format t "CMD-READ: ~%"))
889   ;; ($)r file
890   ;;         Reads  file  to after the addressed line.  If file is not
891   ;;         specified, then the default filename is used.   If  there
892   ;;         was  no  default  filename prior to the command, then the
893   ;;         default filename is set to file.  Otherwise, the  default
894   ;;         filename is unchanged.  The current address is set to the
895   ;;         last line read.
896   ;;
897   ;; ($)r !command
898   ;;         Reads to after the addressed line the standard output  of
899   ;;         `!command',  (see the !command below).  The default file-
900   ;;         name is unchanged.  The current address  is  set  to  the
901   ;;         last line read.
902   (with-addresses (buffer (curr to 1))
903     (cmd-edit-or-read buffer arg curr)))
904
905
906 (defun cmd-edit-file-unconditionally (buffer from to arg)
907   (declare (ignore from to))
908   (dbg (format t "CMD-EDIT-FILE-UNCONDITIONALLY: ~%"))
909   ;; E file  Edits  file  unconditionally.   This  is similar to the e
910   ;;         command, except  that  unwritten  changes  are  discarded
911   ;;         without  warning.  The current address is set to the last
912   ;;         line read.
913   (cmd-edit-or-read buffer arg nil)
914   (unless (buffer-got-error buffer)
915     (setf (buffer-modified buffer) nil)
916     (format *terminal-io* "~D~%" (buffer-current-linum buffer))))
917
918   
919 (defun cmd-edit-file (buffer from to arg)
920   (declare (ignore from to))
921   (dbg (format t "CMD-EDIT-FILE: ~%"))
922   ;; e file  Edits  file,  and  sets the default filename.  If file is
923   ;;         not specified, then the  default filename is  used.   Any
924   ;;         lines  in  the  buffer are deleted before the new file is
925   ;;         read.  The current address is set to the last line  read.
926   ;;
927   ;; e !command
928   ;;         Edits  the  standard  output of `!command', (see !command
929   ;;         below).  The default filename is unchanged.  Any lines in
930   ;;         the  buffer  are  deleted before the output of command is
931   ;;         read.  The current address is set to the last line  read.
932   (unless-modified buffer
933      (cmd-edit-or-read buffer arg nil)))
934
935
936 (defun cmd-set-default-filename (buffer from to arg)
937   (declare (ignore from to))
938   (dbg (format t "CMD-SET-DEFAULT-FILENAME: ~%"))
939   ;; f file  Sets the default filename to file.  If file is not speci-
940   ;;         fied, then the default unescaped filename is printed.
941   (when (string/= "" arg)
942     (let ((pos (skip-spaces arg)))
943       (when (and pos (< 0 pos)) (setq arg (subseq arg pos))))
944     (if (or (string= "" arg)
945             (handler-case (prog1 nil (probe-file arg)) (error nil t)))
946         (buffer-set-error buffer "Invalid filename")
947         (setf (buffer-path buffer) arg)))
948   (format *terminal-io* "~A~%" (buffer-path buffer)))
949
950
951 (defun cmd-print-last-error (buffer from to arg)
952   (declare (ignore from to arg))
953   (dbg (format t "CMD-PRINT-LAST-ERROR: ~%"))
954   ;; h       Prints an explanation of the last error.
955   (format *terminal-io* "~A~%" (buffer-last-error buffer)))
956
957
958 (defun cmd-toggle-error-explanations (buffer from to arg)
959   (declare (ignore from to arg))
960   (dbg (format t "CMD-TOGGLE-ERROR-EXPLANATIONS: ~%"))
961   ;; H       Toggles  the printing of error explanations.  By default,
962   ;;         explanations are not printed.  It is recommended that  ed
963   ;;         scripts begin with this command to aid in debugging.
964   (toggle (buffer-show-errors buffer))
965   (unless (string= "" (buffer-last-error buffer))
966     (format *terminal-io* "~A~%" (buffer-last-error buffer))))
967
968
969 (defun cmd-toggle-command-prompt (buffer from to arg)
970   (declare (ignore from to arg))
971   (dbg (format t "CMD-TOGGLE-COMMAND-PROMPT: ~%"))
972   ;; P       Toggles  the  command prompt on and off.  Unless a prompt
973   ;;         was specified by with command-line option -p string,  the
974   ;;         command prompt is by default turned off.
975   (toggle (buffer-show-prompt buffer)))
976
977
978 (defun cmd-quit (buffer from to arg)
979   (declare (ignore from to arg))
980   (dbg (format t "CMD-QUIT: ~%"))
981   ;; q       Quits ed.
982   (unless-modified buffer
983      (setf (buffer-quit buffer) t)))
984
985
986 (defun cmd-quit-unconditionnaly (buffer from to arg)
987   (declare (ignore from to arg))
988   (dbg (format t "CMD-QUIT-UNCONDITIONNALY: ~%"))
989   ;; Q       Quits  ed unconditionally.  This is similar to the q com-
990   ;;         mand, except that unwritten changes are discarded without
991   ;;         warning.
992   (setf (buffer-quit buffer) t))
993
994
995 (defun cmd-subshell (buffer from to arg)
996   (declare (ignore from to))
997   (dbg (format t "CMD-SUBSHELL: ~%"))
998   ;; !command
999   ;;         Executes  command  via  sh(1).  If the first character of
1000   ;;         command is `!', then it is replaced by text of the previ-
1001   ;;         ous  `!command'.   ed  does not process command for back-
1002   ;;         slash (\) escapes.  However, an unescaped `%' is replaced
1003   ;;         by  the  default  filename.   When the shell returns from
1004   ;;         execution, a `!'  is printed to the standard output.  The
1005   ;;         current line is unchanged.
1006   (setf (buffer-command buffer)
1007         (if (char= (character "!") (char arg 0))
1008             (concatenate 'string (buffer-command buffer) (subseq arg 1))
1009             arg))
1010   (do-command buffer))
1011
1012
1013
1014 (defparameter *commands*
1015   '( ;;cmd from   to    argument     p   function
1016     ("t"  :curr  :curr  :curr        t   cmd-copy-lines)
1017     ("m"  :curr  :curr  :curr        t   cmd-move-lines)
1018     ("c"  :curr  :curr  nil          t   cmd-change-lines)
1019     ("#"  :curr  :curr  nil          t   cmd-comment)
1020     ("y"  :curr  :curr  nil          t   cmd-copy)
1021     ("d"  :curr  :curr  nil          t   cmd-delete-lines)
1022     ("p"  :curr  :curr  nil          t   cmd-print-lines)
1023     ("n"  :curr  :curr  nil          t   cmd-print-lines-and-numbers)
1024     ("l"  :curr  :curr  nil          t   cmd-print-lines-unambiguously)
1025     ("s"  :curr  :curr  substitution t   cmd-substitute)
1026     ("j"  :curr  :next  nil          t   cmd-join-lines)
1027     ("g"  :first :last  regexp       nil cmd-edit-matching)
1028     ("v"  :first :last  regexp       nil cmd-edit-not-matching)
1029     ("G"  :first :last  regexp       t   cmd-user-edit-matching)
1030     ("V"  :first :last  regexp       t   cmd-user-edit-not-matching)
1031     ("W"  :first :last  string       nil cmd-append-file)
1032     ("w"  :first :last  string       nil cmd-write-file)
1033     ("k"  nil    :curr  character    t   cmd-mark)
1034     ("a"  nil    :curr  nil          t   cmd-append)
1035     ("i"  nil    :curr  nil          t   cmd-insert)
1036     ("x"  nil    :curr  nil          t   cmd-paste)
1037     ("="  nil    :last  nil          t   cmd-print-line-number)
1038     ("r"  nil    :last  string       nil cmd-read-file)
1039     (nil  nil    :next  nil          nil cmd-print-lines)
1040     ("z"  nil    :next  number       t   cmd-scroll-lines)
1041     ("h"  nil    nil    nil          t   cmd-print-last-error)
1042     ("q"  nil    nil    nil          t   cmd-quit)
1043     ("Q"  nil    nil    nil          t   cmd-quit-unconditionnaly)
1044     ("P"  nil    nil    nil          t   cmd-toggle-command-prompt)
1045     ("H"  nil    nil    nil          t   cmd-toggle-error-explanations)
1046     ("u"  nil    nil    nil          t   cmd-undo)
1047     ("e"  nil    nil    string       nil cmd-edit-file)
1048     ("E"  nil    nil    string       nil cmd-edit-file-unconditionally)
1049     ("f"  nil    nil    string       nil cmd-set-default-filename)
1050     ("!"  nil    nil    string       nil cmd-subshell)
1051     ("wq" :first :last  string       nil cmd-write-file-quit)))
1052
1053
1054 (dbg
1055  (push '("D"  nil    nil    nil          nil cmd-toggle-debug) *commands*)
1056  (defun cmd-toggle-debug (buffer from to arg)
1057    ;; !command
1058    ;;         Executes  command  via  sh(1).  If the first character of
1059    ;;         command is `!', then it is replaced by text of the previ-
1060    ;;         ous  `!command'.   ed  does not process command for back-
1061    ;;         slash (\) escapes.  However, an unescaped `%' is replaced
1062    ;;         by  the  default  filename.   When the shell returns from
1063    ;;         execution, a `!'  is printed to the standard output.  The
1064    ;;         current line is unchanged.
1065    (declare (ignore buffer from to arg))
1066    (dbg (format t "CMD-toggle-debug: ~%"))
1067    (toggle *show-debug*)))
1068
1069
1070
1071 (defun skip-spaces (command &optional (start 0))
1072   "
1073 RETURN: The index of the next non white space character in command,
1074         starting from position, or nil if end of string.
1075 "
1076   (do ((start start (1+ start)))
1077       ((or (>= start (length command))
1078            (char/= (character " ") (char command start)))
1079        (when (< start (length command)) start))))
1080
1081 ;;addresses -->   address
1082 ;;              | address ',' address
1083 ;;              | ',' | '%' , ';' .
1084 ;;
1085 ;;
1086 ;;address -->   '.' | '$' | number
1087 ;;            | '-' | '^' | '-' number | '^' number
1088 ;;                  | '+' | '+' number | space number
1089 ;;                  | '/' re '/' | '?' re '?' | '//' | '??'
1090 ;;                  | "'" lc .
1091 ;;
1092 ;;lc --> 'a'|'b'|'c'|'d'|'e'|'f'|'g'|'h'|'i'|'j'|'k'|'l'|'m'
1093 ;;      |'n'|'o'|'p'|'q'|'r'|'s'|'t'|'u'|'v'|'w'|'x'|'y'|'z'.
1094 ;;
1095 ;;re --> [first] ( ch | '\' ch | '[' char-class ']' | '[' '^' char-class ']'
1096 ;;                | '^' | '$' | '\(' re '\)' | re '*'
1097 ;;                | re '\{' num ',' num '\}'
1098 ;;                | re '\{' num ','  '\}'
1099 ;;                | re '\{' num '\}'
1100 ;;                | '\<' | '\>' | '\`' | "\'" | re '\?' | re '\+'
1101 ;;                | '\b' | '\B' | '\w' | '\W' .
1102 ;;first --> '*' .
1103 ;;
1104 ;;char-class --> '[:alnum:]'|'[:cntrl:]'|'[:lower:]'|'[:space:]'
1105 ;;              |'[:alpha:]'|'[:digit:]'|'[:print:]'|'[:upper:]'
1106 ;;              |'[:blank:]'|'[:graph:]'|'[:punct:]'|'[:xdigit:]'
1107 ;;              |'[.'col-elm'.]'|'[='col-elm'=]'.
1108 ;;col-elm --> .
1109
1110   
1111 (defun parse-address (command position)
1112   ;;address -->   '.' | '$' | number
1113   ;;            | '-' | '^' | '-' number | '^' number
1114   ;;                  | '+' | '+' number | space number
1115   ;;                  | '/' re '/' | '?' re '?' | '//' | '??'
1116   ;;                  | "'" lc .
1117   (declare (integer position))
1118   (let ((address nil) (ch))
1119     (flet ((parse-optional-number
1120                ()
1121              (setq position (skip-spaces command (1+ position)))
1122              (when (and position
1123                         (setq ch (char command position))
1124                         (digit-char-p ch))
1125                (multiple-value-bind (value pos)
1126                    (parse-integer command :start position :junk-allowed t)
1127                  (when value
1128                    (setq address (cons address value)))
1129                  (setq position pos)))))
1130       (setq position (skip-spaces command position))
1131       (when position
1132         (setq ch (char command position))
1133         (cond
1134           ((char= ch (character ".")) (setq address :curr) (incf position))
1135           ((char= ch (character "$")) (setq address :last) (incf position))
1136           ((digit-char-p ch)
1137            (multiple-value-bind (value pos)
1138                (parse-integer command :start position :junk-allowed t)
1139              (when value
1140                (setq address (cons :linum value)))
1141              (setq position pos)))
1142           ((or (char= ch (character "^")) (char= ch (character "-")))
1143            (setq address :prev)
1144            (parse-optional-number))
1145           ((or (char= ch (character " ")) (char= ch (character "+")))
1146            (setq address :next)
1147            (parse-optional-number))
1148           ((or (char= ch (character "/")) (char= ch (character "?")))
1149            ;; TODO: regexp
1150            ;; eat regexp:
1151            (setq address
1152                  (cons :regexp 
1153                        (do ((terminator ch)
1154                             (end position (1+ end)))
1155                            ((or (>= end (length command))
1156                                 (char= terminator (char command end)))
1157                             (prog1 (subseq command position (1+ end))
1158                               (setq position (1+ end))))
1159                          (declare (integer end))))))
1160           ((char= ch (character "'"))
1161            (incf position)
1162            ;; TODO: when there is an error here it's: "Invalid mark character"
1163            ;; TODO: not: "Invalid address" !
1164            (when (< position (length command))
1165              (setq address (cons :mark (char command position)))
1166              (incf position)))
1167           )))
1168     (values address position)))
1169
1170
1171 (defun parse-and-run-command (buffer command)
1172   (let ((position (skip-spaces command))
1173         (cmd) (ch) (from) (to) (arg) (print nil))
1174     (buffer-clear-error buffer)
1175     (macrolet ((set-error (message) `(buffer-set-error buffer ,message))
1176                (got-error () `(buffer-got-error buffer)))
1177       (when position
1178         (setq ch (char command position))
1179         (cond
1180           ((or (char= (character ",") ch)  (char= (character "%") ch))
1181            (setq from :first to :last)
1182            (setq position (skip-spaces command (1+ position))))
1183           ((char= (character ";") ch)
1184            (setq from :curr  to :last)
1185            (setq position (skip-spaces command (1+ position))))
1186           ((not (alpha-char-p ch))
1187            (multiple-value-setq (to position) (parse-address command position))
1188            (if (eq to :error)
1189                (set-error "Invalid address")
1190                (progn
1191                  (setq position (skip-spaces command position))
1192                  (when position
1193                    (setq ch (char command position))
1194                    (when (char= (character ",") ch)
1195                      (setq from to)
1196                      (multiple-value-setq (to position)
1197                        (parse-address command (1+ position)))
1198                      (if (eq to :error)
1199                          (set-error "Invalid address")
1200                          (setq position (skip-spaces command position))))))))))
1201       (dbg (format t "PARC: from= ~S to= ~S position= ~S got-error= ~S~%"
1202                    from to position (got-error)))
1203       (unless (got-error)
1204         (if (null position)
1205             (setq cmd (assoc nil *commands*))
1206             (setq cmd (assoc (subseq command position (1+ position)) *commands*
1207                              :test (function string=))
1208                   position (1+ position)))
1209         (dbg (format t "PARC: command key= ~S ~%      cmd= ~S~%"
1210                      (when position (subseq command (1- position) position))
1211                      (nconc (butlast cmd)
1212                             (list (symbol-name (car (last cmd)))))))
1213         (let ((defr (second cmd))
1214               (deto (third  cmd))
1215               (argk (fourth cmd))
1216               (accp (fifth  cmd))
1217               (cmdf (sixth  cmd)))
1218           (unless from (setq from defr))
1219           (unless to   (setq to   deto))
1220           (case argk
1221             ((nil))
1222             ((character)
1223              (if (and position (< position (length command))
1224                       (alpha-char-p (char command position))
1225                       (lower-case-p (char command position)))
1226                  (setf arg (char command position))
1227                  (set-error "Invalid mark character")))
1228             ((number)
1229              (when position
1230                (multiple-value-setq (arg position)
1231                  (parse-integer command :start position :junk-allowed t))
1232                (unless arg
1233                  (set-error "Invalid address"))))
1234             ((string)
1235              (when position
1236                (setq arg (subseq command position)
1237                      position (length command))))
1238             ((regexp)
1239              )
1240             ((substitution)
1241              )
1242             ((:curr)
1243              (when position
1244                (multiple-value-setq (arg position)
1245                  (parse-address command position))
1246                (cond
1247                  ((eq arg :error)  (set-error "Invalid address"))
1248                  ((null arg) (setq arg :curr)))))
1249             (otherwise
1250              (set-error "Internal error: *command* table.")))
1251           (dbg (format t "PARC: from= ~S to= ~S position= ~S got-error= ~S~%"
1252                        from to position (got-error))
1253                (format t "      arg= ~S ~%" arg))
1254           (unless (got-error)
1255             (if (and accp position (< position (length command))
1256                      (char= (character "p") (char command position)))
1257                 (setq  print t)
1258                 (when (and position (skip-spaces command position))
1259                   (set-error "Invalid command suffix")))
1260             (unless (got-error)
1261               (dbg (format t "PARC: calling (~A ~S ~S ~S ~S ~S)~%"
1262                            cmdf "BUFFER" from to arg print))
1263               (setf (buffer-print buffer) print)
1264               (funcall cmdf buffer from to arg))))))))
1265
1266
1267 (defun edit (buffer)
1268   (format *terminal-io* "~&")
1269   (setf (buffer-quit buffer) nil)
1270   (format *terminal-io* "~D~%" (buffer-length buffer))
1271   (loop
1272      (let ((command (read-line *terminal-io* nil nil)))
1273        (unless command (return))
1274        (dbg (format t "EDIT: read command ~S~%" command))
1275        (setf (buffer-print buffer) nil)
1276        (buffer-clear-error buffer)
1277        (parse-and-run-command buffer command)
1278        (dbg (format t "EDIT: parc returned (~S ~S ~S)~%"
1279                     (buffer-print buffer)
1280                     (buffer-got-error buffer)
1281                     (buffer-quit buffer)))
1282        (if (buffer-got-error buffer)
1283            (if (buffer-show-errors buffer)
1284                (format *terminal-io* "~A~%" (buffer-last-error buffer))
1285                (format *terminal-io* "?~%"))
1286            (when (buffer-print buffer)
1287              (let ((current (buffer-current-linum buffer)))
1288                (if (limit current 1 (buffer-length buffer))
1289                    (format *terminal-io* "~A~%" (buffer-nth-line buffer current))
1290                    (progn
1291                      (buffer-set-error buffer "Invalid address")
1292                      (if (buffer-show-errors buffer)
1293                          (format *terminal-io* "~A~%" (buffer-last-error buffer))
1294                          (format *terminal-io* "?~%")))))))
1295        (if (buffer-quit buffer)
1296            (return)
1297            (when (buffer-show-prompt buffer)
1298              (format *terminal-io* "~A~%" (buffer-prompt-string buffer)))))))
1299
1300
1301 ;; ed &optional x => implementation-dependent
1302 ;;
1303 ;;
1304 ;;
1305 ;; Arguments and Values:
1306 ;;
1307 ;;
1308 ;; x---nil, a pathname, a string, or a function name. The default is nil.
1309 ;;
1310 ;;
1311 ;; Description:
1312 ;;
1313 ;;
1314 ;; ed invokes the editor if the implementation provides a resident editor.
1315 ;;
1316 ;; If x is nil, the editor is entered. If the editor had been previously
1317 ;; entered, its prior state is resumed, if possible.
1318 ;;
1319 ;; If x is a pathname or string, it is taken as the pathname designator
1320 ;; for a file to be edited.
1321 ;;
1322 ;; If x is a function name, the text of its definition is edited. The
1323 ;; means by which the function text is obtained is implementation-defined.
1324
1325
1326 (defparameter *current-buffer* (make-buffer))
1327
1328
1329 (defun ed (&optional x)
1330   "
1331 DO:  Invokes the ed(1)-like editor.
1332 X:   NIL, a pathname, a string, or a function name. The default is NIL.
1333 "
1334   (cond
1335     ((null x)
1336      (edit *current-buffer*))
1337     ((or (pathnamep x) (stringp x))
1338      (setq *current-buffer* (buffer-read x))
1339      (edit *current-buffer*))
1340     ((symbolp x)
1341      (let ((fle (function-lambda-expression (fdefinition x))))
1342        (setq *current-buffer*
1343              (buffer-from-string
1344               (if (eq 'lambda (car fle))
1345                   (format nil "~S~%"  (cons 'defun (cons x (cdr fle))))
1346                   (format nil "~S is not a function.~%" x))))
1347        (edit *current-buffer*)))
1348     ;; TODO: If x is a function name, ...
1349     (t
1350      (error "Invalid argument ~S." x))))
1351
1352
1353
1354
1355 (defvar test-text
1356   "One little boy and
1357 Two little girls, climbed up a
1358 Tree near the sky.
1359 Four birds landed on that tree.
1360 Five eggs were layed each on one child head.
1361 ") 
1362
1363 ;; (progn (ext:cd "/home/pascal/src/lisp/encours/") (load "ed.lisp"))
1364
1365 ;;;; THE END ;;;;