Corrected typo.
[com-informatimago:emacs.git] / pjb-sources.el
1 ;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               pjb-sources.el
4 ;;;;LANGUAGE:           emacs lisp
5 ;;;;SYSTEM:             emacs
6 ;;;;USER-INTERFACE:     emacs
7 ;;;;DESCRIPTION
8 ;;;;
9 ;;;;    This module exports functions helpful in writting programs.
10 ;;;;    
11 ;;;;    See also state-coding.el
12 ;;;;
13 ;;;;AUTHORS
14 ;;;;    <PJB> Pascal J. Bourguignon 
15 ;;;;MODIFICATIONS
16 ;;;;    2006-03-21 <PJB> Added convert-alternative.
17 ;;;;    2004-11-01 <PJB> Renamed carnot to karnaugh.
18 ;;;;                     Nicolas Léonard Sadi Carnot (1796 - 1832)
19 ;;;;                     -- French Mathematician (2nd law of thermodynamics) vs. 
20 ;;;;                     Maurice Karnaugh 
21 ;;;;                     -- Bell Labs Telecommunication Engineer.
22 ;;;;                     Thanks to josephoswaldgg@hotmail.com for reminding me 
23 ;;;;                     the correct name.
24 ;;;;    2004-09-16 <PJB> Corrected an out-of-bound bug in case-lisp-region
25 ;;;;                     reported by starseeke@cy.iec.udel.edu
26 ;;;;    2004-03-23 <PJB> Added insert-columns.
27 ;;;;    2003-06-02 <PJB> Corrected pjb-add-change-log-entry
28 ;;;;    2003-01-20 <PJB> Added walk-sexps, map-sexps, replace-sexps; 
29 ;;;;                     reimplemented get-sexps with walk-sexps.
30 ;;;;    2003-01-19 <PJB> Added comment regexp in pjb-sources-data.
31 ;;;;    2003-01-18 <PJB> Added pjb-add-change-log-entry.
32 ;;;;    2003-01-17 <PJB> Made pjb-update-eof use mode instead of filename.
33 ;;;;    2003-01-08 <PJB> Moved in pjb-class & pjb-attrib.
34 ;;;;    2001-01-15 <PJB> Updated pjb-update-eof.
35 ;;;;    199?-??-?? <PJB> Creation.
36 ;;;;BUGS
37 ;;;;LEGAL
38 ;;;;    LGPL
39 ;;;;
40 ;;;;    Copyright Pascal Bourguignon 1990 - 2011
41 ;;;;
42 ;;;;    This library is free software; you can redistribute it and/or
43 ;;;;    modify it under the terms of the GNU Lesser General Public
44 ;;;;    License as published by the Free Software Foundation; either
45 ;;;;    version 2 of the License, or (at your option) any later version.
46 ;;;;
47 ;;;;    This library is distributed in the hope that it will be useful,
48 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
49 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
50 ;;;;    Lesser General Public License for more details.
51 ;;;;
52 ;;;;    You should have received a copy of the GNU Lesser General Public
53 ;;;;    License along with this library; if not, write to the Free Software
54 ;;;;    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
55 ;;;;
56 ;;;;****************************************************************************
57 (require 'font-lock)
58 (require 'add-log)
59
60 (require 'pjb-cl)
61 (require 'pjb-utilities)
62
63
64 ;; egrep 'defun|defmacro' pjb-sources.el|sed -e 's/(def\(un\|macro\) /;; /'
65
66 ;; pjb-find (item seq &rest cl-keys)
67
68 ;; upcase-lisp-region (start end)
69 ;; upcase-lisp ()
70 ;; downcase-lisp-region (start end)
71 ;; downcase-lisp ()
72
73 ;; skip-comments ()
74 ;; walk-sexps (fun)
75 ;; map-sexps (source-file fun &rest cl-keys)
76 ;; get-sexps (source-file &rest cl-keys)
77 ;; replace-sexps (source-file transformer &rest cl-keys)
78
79 ;; pjb-attrib (name type &rest args)
80 ;; pjb-defclass (name super &rest args)
81
82 ;; integer-to-bool-list (n &rest cl-keys)
83
84 ;; karnaugh-solve (conditions actions table &optional bool-vals action-vals)
85 ;; karnaugh (conditions actions &optional bool-vals)
86
87 ;; pjb-add-change-log-entry (&optional log-entry)
88 ;; pjb-update-eof (&optional *silent*)
89
90 ;; pjb-grep-here (pattern)
91
92 ;; generate-options (options defaults)
93
94
95
96 (defun mode-name (&optional mode)
97   "
98 RETURN: A string containing the name of the mode, without the -mode suffix.
99 "
100   (let ((mode (string* (or mode major-mode))))
101     (if (and (< 5 (length mode))
102              (string= "-mode" (subseq mode (- (length mode) 5))))
103         (subseq mode 0 (- (length mode) 5))
104         mode)))
105
106 ;; ------------------------------------------------------------------------
107
108 (defun ooestimate (project-name
109                    key-class-count         ;; 1+
110                    reusable-domain-objects ;; 0+
111                    user-interface-complexity ;; 1,2,3
112                    person-count              ;; 1+
113                    experience-ratio          ;; [0.0 .. 1.0]
114                    )
115   (interactive "sProject name: 
116 nKey Class Count: 
117 nReusable Domain Objects: 
118 nUser Interface Complexity (1 2 3): 
119 nPerson Count: 
120 nExperience Ratio [0.0,1.0]: ")
121   (let* ((person-day-per-class (+ 15 (* 2.5 (- 1.0 experience-ratio))))
122          (total-class-count    (* key-class-count 
123                                   (+ 1.0 user-interface-complexity)))
124          (total-person-days (* total-class-count person-day-per-class))
125          (total-months (/ total-person-days 20.000000 person-count)))
126     (insert
127      (concatenate 'string
128        (format "OOEstimate for Project %s:\n\n" project-name)
129        (format "   key class count:           %6d\n" key-class-count)
130        (format "   reusable domain objects:   %6d\n" reusable-domain-objects)
131        (format "   user interface complexity: %s\n"
132          (cdr (assoc user-interface-complexity
133                      '((1 . "simple") (2 . "medium") (3 . "complex")))))
134        (format "   person count:              %6d\n" person-count)
135        (format "   experience ratio:          %6.1f\n" experience-ratio)
136        (format "\n")
137        (format "   total class count:         %6d\n" total-class-count)
138        (format "   person day per class       %6.1f\n" person-day-per-class)
139        (format "   total person days:         %6d\n" total-person-days)
140        (format "   total months:              %6d\n" total-months)))))
141
142
143 ;; ------------------------------------------------------------------------
144
145
146 ;; TODO: move this to pjb-cl or somewhere...
147 (defun pjb-find (item seq &rest cl-keys)
148   "
149 DO:     Like Common-Lisp find, but we cannot use find from 'cl because
150         Common-Lisp does not specify which of the item and of the seq element
151         is passed first or second argument of test...
152         This one specify that item is passed as first argument and the
153         key from the seq as second element.
154         Common-Lisp does not specify either what happens when both 
155         :test and :test-not are given.
156         If both are given, this function calls both as in:
157          (if (and (test item key) (not (test-not item key))) :found :not-found)
158         Common-Lisp does not specify what test is done when :test and 
159         :test-not are not specified.
160         This function specify that the default for :test is (equal item key)
161         and the default for :test-not is no test.
162
163         The element tested are (elt seq :start), (elt seq (+ :start 1))
164         ... (elt seq (- :end 2)) (elt seq (- :end 1)).
165         The default for :start is 0 and for :end is (length seq).
166         (Note that Common-Lisp specifies as default for :end nil, but this
167         is not compatible with the definition of _bounded_ which ask for 
168         a numerical index!)
169 "
170   (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end) ()
171     (setf cl-key  (or cl-key (function identity)))
172     (flet ((found (item key) nil))
173       (if cl-test
174           (if cl-test-not 
175               (fset 'found (lambda (item key) 
176                              (and (funcall cl-test item key)
177                                   (not (funcall cl-test-not item key)))))
178               (fset 'found cl-test))
179           (if cl-test-not
180               (fset 'found (lambda (item key) (not (funcall cl-test item key))))
181               (fset 'found (function equal))))
182       (setf cl-end (or cl-end (length seq)))
183       ;;(show item seq cl-test cl-test-not cl-key cl-start cl-end cl-from-end)
184       (if cl-from-end
185           ;; loop does not specifies that loop variables are available in
186           ;; finally, so it's quite useless too.
187           ;; TODO: In case of consp, work on (nreverse (subseq seq start end))
188           (do ((i (1- cl-end) (1- i))
189                (element)
190                (key)
191                (result nil))
192               ((or result (< i cl-start)) result)
193             (setf element (elt seq i))
194             (setf key (funcall cl-key element))
195             (when (found item key) (setq result element)))
196           (if (consp seq)
197               (progn
198                 (do ((i 0 (1+ i)))
199                     ((<= cl-start i))
200                   (setf seq (cdr seq)))
201                 (do* ((i cl-start (1+ i))
202                       (elements seq (cdr elements))
203                       (element (car elements) (car elements))
204                       (key (funcall cl-key element) (funcall cl-key element)))
205                      ((or (<= cl-end i) (endp elements) (found item key)) 
206                       (if (or (<= cl-end i) (endp elements)) nil element))
207                   ))
208               (do ((i cl-start (1+ i))
209                    (element)
210                    (key)
211                    (result nil))
212                   ((or result (<= cl-end i)) result)
213                 (setf element (elt seq i))
214                 (setf key (funcall cl-key element))
215                 (printf "%s %s %s %s \n" i  element key (found item key))
216                 (when (found item key) (setq result element))))))))
217
218
219 ;; ------------------------------------------------------------------------
220 ;; pjb-sources-data
221 ;; ------------------------------------------------------------------------
222 ;; some data about source files.
223
224 (defparameter *lisp-modes*
225   '(emacs-lisp-mode ledit-mode
226     lisp-interaction-mode lisp-mode scheme-mode
227     common-lisp-mode fi:common-lisp-mode)
228   "A list of major modes used to edit lisp or sexp files.")
229
230 (defstruct (header-comment-description
231              (:type list)
232              (:conc-name hcd-))
233   major-modes
234   header-first-format
235   header-title-format
236   header-comment-format
237   header-last-format
238   eof-format 
239   comment-regexp)
240
241
242 (defparameter *header-comment-descriptions*
243   `(((ada-mode snmp-mode snmpv2-mode vhdl-mode sql-mode)
244      "--%s"
245      "--%s"
246      "--    %s"
247      "--%s"
248      "---- %-32s -- %19s -- %-8s ----" 
249      "--.*$")
250     ((dcl-mode simula-mode )
251      "!!%s"
252      "!!%s"
253      "!!    %s"
254      "!!%s"
255      "!!!! %-32s -- %19s -- %-8s !!!!" 
256      "!.*$")
257     ((c++-mode c-initialize-cc-mode c-mode cperl-mode cwarn-mode
258                idl-mode idlwave-mode java-mode objc-mode pike-mode
259                prolog-mode )
260      "/*%s"
261      "%s"
262      "    %s"
263      "%s*/"
264      "/*** %-32s -- %19s -- %-8s ***/" 
265      "\\(/\\*.*?\\*/\\)\\|\\(//.*$\\)")
266     (,(append '(asm-mode dsssl-mode zone-mode) *lisp-modes*)
267       ";;;;%s"
268       ";;;;%s"
269       ";;;;    %s"
270       ";;;;%s"
271       ";;;; %-32s -- %19s -- %-8s ;;;;" 
272       "\\(#|\\([^|]\\||[^#]\\)*|#\\)\\|\\(;.*$\\)")
273     ((text-mode)
274      "\\(/\\*.*?\\*/\\)\\|\\(//.*$\\)") ;; \(/\*.*?\*/\)\|\(//.*$\)
275
276     ;; ( LSOURCE    ";;;; %-32s -- %19s -- %-8s ;;;;" 
277     ;;  (asm-mode dsssl-mode emacs-lisp-mode ledit-mode
278     ;;   lisp-interaction-mode lisp-mode scheme-mode
279     ;;   common-lisp-mode fi:common-lisp-mode
280     ;;   zone-mode  )
281     ;;  ";;;;%s"
282     ;;  ";;;;%s"
283     ;;  ";;;;%s"
284     ;;  ";;;;    %s"
285     ;;  "\\(#|\\([^|]\\||[^#]\\)*|#\\)\\|\\(;.*$\\)")
286     ;; ( TEXT       "" ;;";;;; %-32s -- %19s -- %-8s ;;;;" 
287     ;;  (text-mode)
288     ;;  "%s"
289     ;;  "%s"
290     ;;  "%s"
291     ;;  "    %s"
292     ;;  "%s"
293     ;;  "" ;;";;;; %-32s -- %19s -- %-8s ;;;;" 
294     ;;  "\\(^;.*$\\)")
295     
296     ((awk-mode eshell-mode icon-mode m4-mode makefile-mode makefile-gmake-mode makefile-bsdmake-mode
297                octave-mode perl-mode sh-mode shell-script-mode
298                tcl-mode )
299      "#%s"
300      "#%s"
301      "#    %s"
302      "#%s"
303      "#### %-32s -- %19s -- %-8s ####" 
304      "#.*$")
305     ((caml-mode delphi-mode modula-2-mode pascal-mode)
306      "(*%s"
307      "%s"
308      "    %s"
309      "%s*)"
310      "(*** %-32s -- %19s -- %-8s ***)" 
311      "(\\*.*?\\*)")
312     ((f90-mode fortran-mode) 
313      "C%s"
314      "C%s"
315      "C    %s"
316      "C%s"
317      "CCCC %-32s -- %19s -- %-8s CCCC"
318      "^C.*$")
319     ((nroff-mode )
320      "\\\"\"\"%s"
321      "\\\"\"\"%s"
322      "\\\"\"\"    %s"
323      "\\\"\"\"%s"
324      "\\\"\"\" %-32s -- %19s -- %-8s \"\"\"\"" 
325      "\\\".*$")
326     ((html-autoview-mode html-mode sgml-mode sgml-name-8bit-mode )
327      "<!--%s"
328      "%s"
329      "    %s"
330      "%s-->"
331      "<!-- %-32s == %19s == %-8s -->" 
332      "<!--.*?-->")
333     ((latex-mode matlab-mode metafont-mode metapost-mode 
334                  plain-TeX-mode plain-tex-mode ps-mode
335                  reftex-index-phrases-mode reftex-mode
336                  slitex-mode tex-mode )
337      "%%%s"
338      "%%%s"
339      "%%    %s"
340      "%%%s"
341      "%%%%%%%% %-32s -- %19s -- %-8s %%%%%%%%" 
342      "%%.*$")
343     ((scribe-mode)
344      "@Comment[%68s]"
345      "@Comment[%67s ]"
346      "@Comment[    %63s ]"
347      "@Comment[%68s]"
348      "@Comment[ %-32s -- %19s -- %-8s ]" 
349      "@Comment\\[[^]]*\\]"))
350   "This list contains pjb-source structures, that are lists composed of:
351    - a tag,
352    - a format string used to make the end of file tag,
353    - a list of (major) modes,
354    - a format string to format comment lines in the header comment,
355    - a regexp string to match a comment in these modes.")
356
357
358 (defun header-comment-description-for-mode (mode)
359   (pjb-find mode *header-comment-descriptions* 
360             :key  (function hcd-major-modes)
361             :test (lambda (item key)
362                       (member* item key :test (function eq)))))
363
364
365
366 (defun random-case-region (start end)
367   (interactive "r")
368   (goto-char start)
369   (let ((chars (buffer-substring start end)))
370     (loop
371        for i from 0 below (length chars)
372        do (setf (aref chars i) (if (zerop (random 2))
373                                    (downcase (aref chars i))
374                                    (upcase   (aref chars i)))))
375     (delete-region start end)
376     (insert chars)))
377
378
379 ;; ------------------------------------------------------------------------
380 ;; Converting LISP symbols between COMMON-LISP and emacs
381 ;; ie. converts to down-case or to up-case only the unescaped symbols.
382 ;;
383
384 (defun skip-to-next-sexp ()
385   (interactive)
386   (while (or
387           (looking-at "\\([ \n\t\v\f\r]+\\)") ;  spaces
388           (looking-at "\\(;.*$\\)")           ;  ;xxx      comment
389           (looking-at "\\(#|\\([^|]\\||[^#]\\)*|#\\)")) ;  #|xxx|#   comment
390     (goto-char (match-end 0))))
391
392 (defun cl-looking-at-what ()
393   (cond
394     ((looking-at "[ \n\t\v\f\r]") :space)
395     ((looking-at ";")  :semicolon-comment) ; ;xxx 
396     ((looking-at "#|") :sharp-comment)     ;  #|xxx|#
397     ((looking-at "\"") :string)            ; "xx\"x"
398     ((looking-at "(")  :beginning-of-list)
399     ((looking-at ")")  :end-of-list)
400     ((looking-at ",@") :comma-at)
401     ((looking-at ",")  :comma)
402     ((looking-at "'")  :quote)
403     ((looking-at "`")  :backquote)
404     (t                 :atom)))
405
406
407 (defun cl-skip-over-sharp-comment ()
408   (let ((start (match-beginning 0)))
409     (goto-char (match-end 0))
410     (loop named :search do
411       (re-search-forward "\\(#|\\||#\\)")
412       (if (string= "#|" (match-string 0))
413           (progn
414             (cl-skip-over-sharp-comment)
415             (goto-char (match-end 0)))
416           (let ((end (match-end 0)))
417             (set-match-data (list start (point)))
418             (return-from :search))))))
419
420 (defun cl-skip-over (&optional what)
421   (setf what (or what (cl-looking-at-what)))
422   (case what
423     ((:space)             (looking-at "[ \n\t\v\f\r]+"))
424     ((:semicolon-comment) (looking-at ";.*$"))
425     ((:sharp-comment)     (when (looking-at "#|")
426                             (cl-skip-over-sharp-comment)
427                             t))
428     ((:string)            (looking-at "\"\\(\\(\\|\\\\.\\|\\\\\n\\)[^\\\\\"]*\\)*\""))
429     ((:beginning-of-list) (looking-at "("))
430     ((:end-of-list)       (looking-at ")"))
431     ((:quote)             (looking-at "'"))
432     ((:backquote)         (looking-at "`"))
433     ((:comma)             (looking-at ","))
434     ((:comma-at)          (looking-at ",@"))
435     ((:atom)              (looking-at
436                            "\\(|[^|]*|\\|\\\\.\\|#[^|]\\|[^\"\\#|;()'`, \n\t\v\f\r\\]\\)+"))
437     (otherwise (error "cannot skip over %s" what)))
438   (goto-char (match-end 0)))
439
440
441 (defun cl-forward  (&optional n)
442   (interactive "p")
443   (setf n (or n 1))
444   (dotimes (i n t)
445     (cl-skip-over)))
446
447
448 (defun cl-what-is-at-point ()
449   (interactive) 
450   (message "%s" (cl-looking-at-what)))
451
452   
453 (defun case-lisp-region (start end transform)
454   "
455 do:      applies transform on all subregions from start to end that are not
456          a quoted character, a quote symbol, a comment (;... or #|...|#), 
457          or a string.
458 "
459   (save-excursion
460     (goto-char start)
461     (while (< (point) end)
462       (while (and (< (point) end)
463                   (or (looking-at "[^\"#|;\\\\]+")
464                       (and (looking-at "#")
465                            (not (looking-at "#|")))))
466         (goto-char (match-end 0)))
467       (funcall transform start (min end (point)))
468       (cl-skip-over)
469       (setq start (point)))))
470
471
472 (defun put-dash-in-name (name)
473   "
474 DO:          Insert a dash between all transitions from lower case
475              to upper case.
476 RETURN:      A new string in upper case and dash.
477 "
478   (do ((parts '())
479        (i 1 (1+ i))
480        (p 0))
481       ((<= (length name) i)
482        (progn
483          (push (string-upcase (subseq name p i)) parts)
484          (unsplit-string (nreverse parts) "-")))
485     (when (and (lower-case-p (char name (1- i)))
486                (upper-case-p (char name i)))
487       (push (string-upcase (subseq name p i)) parts)
488       (setq p i))))
489
490
491 (defun upcase-lisp-region (start end)
492   "
493 DO:      From the start to end, converts to upcase all symbols.
494          Does not touch string literals, comments starting with ';' and
495          symbols quoted with '|' or with '\'.
496 "
497   (interactive "*r")
498   (case-lisp-region start end (function upcase-region))
499   (message "Upcase LISP Done."))
500
501
502 (defun upcase-lisp ()
503   "
504 DO:      From the (point) to (point-max), converts to upcase all symbols.
505          Does not touch string literals, comments starting with ';' and
506          symbols quoted with '|' or with '\'.
507 "
508   (interactive "*")
509   (upcase-lisp-region (point) (point-max)))
510
511
512 (defun downcase-lisp-region (start end)
513   "
514 DO:      From the start to end, converts to low-case all symbols.
515          Does not touch string literals, comments starting with ';' and
516          symbols quoted with '|' or with '\'.
517 "
518   (interactive "*r")
519   (case-lisp-region start end (function downcase-region))
520   (message "Downcase LISP Done."))
521
522
523 (defun downcase-lisp ()
524   "
525 DO:      From the (point) to (point-max), converts to lowcase all symbols.
526          Does not touch string literals, comments starting with ';' and
527          symbols quoted with '|' or with '\'.
528 "
529   (interactive "*")
530   (downcase-lisp-region (point) (point-max)))
531
532
533 (defun pjb-case-insensitive-regexp (start end)
534   "
535 DO:      Replace the selection with a case insensitive regexp,
536          ie. all letter characters are replaced by [Xx] matching
537          both lower case and upper case.
538 "
539   (interactive "r")
540   (do ((letters (concatenate 'string
541                   "ABCDEFGHIJKLMNOPQRSTUVWXYZÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ"
542                   "abcdefghijklmnopqrstuvwxyzàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþ"))
543        (text        (buffer-substring-no-properties start end))
544        (replacement (make-string (* 4 (- end start)) (character " ")))
545        (rlen 0) ;; no fill pointer in emacs lisp...
546        (i    0 (1+ i)))
547       ((>= i (length text))
548        (progn
549          (delete-region start end)
550          (insert (subseq replacement 0 rlen))))
551     (if (position (char text i) letters)
552         (progn
553           (setf (char replacement rlen) (character "["))               
554           (incf rlen)
555           (setf (char replacement rlen) (char-upcase   (char text i))) 
556           (incf rlen)
557           (setf (char replacement rlen) (char-downcase (char text i))) 
558           (incf rlen)
559           (setf (char replacement rlen) (character "]"))               
560           (incf rlen))
561         (progn
562           (setf (char replacement rlen) (char text i)) 
563           (incf rlen)))))
564
565
566 (defun pjb-regexp-not-string-1 (string)
567   (case  (length string)
568     ((0) ".*")
569     ((1) (format "[^%s]*" string))
570     (otherwise
571      (format "\\([^%c]*\\|%c%s\\)" (aref string 0)
572              (aref string 0)
573              (pjb-regexp-not-string-1 (subseq string 1))))))
574
575 (defun pjb-regexp-not-string (string)
576   (let ((all (coerce (delete-duplicates
577                       (sort (coerce string 'list) (function <))) 'string)))
578     (format "^[^%s]*%s[^%s]*$" all (pjb-regexp-not-string-1 string) all)))
579
580
581 (defconstant *apl-letters*
582   '("I-BEAM" "SQUISH-QUAD" "QUAD-EQUAL" "QUAD-DIVIDE" "QUAD-DIAMOND" "QUAD-JOT"
583     "QUAD-CIRCLE" "CIRCLE-STILE" "CIRCLE-JOT" "SLASH-BAR" "BACKSLASH-BAR"
584     "QUAD-SLASH" "QUAD-BACKSLASH" "QUAD-LESS-THAN" "QUAD-GREATER-THAN"
585     "LEFTWARDS-VANE" "RIGHTWARDS-VANE" "QUAD-LEFTWARDS-ARROW"
586     "QUAD-RIGHTWARDS-ARROW" "CIRCLE-BACKSLASH" "DOWN-TACK-UNDERBAR" "DELTA-STILE"
587     "QUAD-DOWN-CARET" "QUAD-DELTA" "DOWN-TACK-JOT" "UPWARDS-VANE"
588     "QUAD-UPWARDS-ARROW" "UP-TACK-OVERBAR" "DEL-STILE" "QUAD-UP-CARET" "QUAD-DEL"
589     "UP-TACK-JOT" "DOWNWARDS-VANE" "QUAD-DOWNWARDS-ARROW" "QUOTE-UNDERBAR"
590     "DELTA-UNDERBAR" "DIAMOND-UNDERBAR" "JOT-UNDERBAR" "CIRCLE-UNDERBAR"
591     "UP-SHOE-JOT" "QUOTE-QUAD" "CIRCLE-STAR" "QUAD-COLON" "UP-TACK-DIAERESIS"
592     "DEL-DIAERESIS" "STAR-DIAERESIS" "JOT-DIAERESIS" "CIRCLE-DIAERESIS"
593     "DOWN-SHOE-STILE" "LEFT-SHOE-STILE" "TILDE-DIAERESIS" 
594     "GREATER-THAN-DIAERESIS" "COMMA-BAR" "DEL-TILDE" "ZILDE" 
595     "STILE-TILDE" "SEMICOLON-UNDERBAR"
596     "QUAD-NOT-EQUAL" "QUAD-QUESTION" "DOWN-CARET-TILDE" "UP-CARET-TILDE" 
597     nil nil nil "ALPHA-UNDERBAR" "EPSILON-UNDERBAR" "IOTA-UNDERBAR"
598     "OMEGA-UNDERBAR" nil)
599   "APL functional characters from unicode.")
600
601 ;; (dolist (l (sort (cons "QUAD" (copy-list *apl-letters*)) (function STRING<))) (insert (format ";; %s %s\n" l (replace-regexp-in-string "-" " " l))))
602
603 ;; ALPHA-UNDERBAR ALPHA UNDERBAR
604 ;; BACKSLASH-BAR BACKSLASH BAR
605 ;; CIRCLE-BACKSLASH CIRCLE BACKSLASH
606 ;; CIRCLE-DIAERESIS CIRCLE DIAERESIS
607 ;; CIRCLE-JOT CIRCLE JOT
608 ;; CIRCLE-STAR CIRCLE STAR
609 ;; CIRCLE-STILE CIRCLE STILE
610 ;; CIRCLE-UNDERBAR CIRCLE UNDERBAR
611 ;; COMMA-BAR COMMA BAR
612 ;; DEL-DIAERESIS DEL DIAERESIS
613 ;; DEL-STILE DEL STILE
614 ;; DEL-TILDE DEL TILDE
615 ;; DELTA-STILE DELTA STILE
616 ;; DELTA-UNDERBAR DELTA UNDERBAR
617 ;; DIAMOND-UNDERBAR DIAMOND UNDERBAR
618 ;; DOWN-CARET-TILDE DOWN CARET TILDE
619 ;; DOWN-SHOE-STILE DOWN SHOE STILE
620 ;; DOWN-TACK-JOT DOWN TACK JOT
621 ;; DOWN-TACK-UNDERBAR DOWN TACK UNDERBAR
622 ;; DOWNWARDS-VANE DOWNWARDS VANE
623 ;; EPSILON-UNDERBAR EPSILON UNDERBAR
624 ;; GREATER-THAN-DIAERESIS GREATER THAN DIAERESIS
625 ;; I-BEAM I BEAM
626 ;; IOTA-UNDERBAR IOTA UNDERBAR
627 ;; JOT-DIAERESIS JOT DIAERESIS
628 ;; JOT-UNDERBAR JOT UNDERBAR
629 ;; LEFT-SHOE-STILE LEFT SHOE STILE
630 ;; LEFTWARDS-VANE LEFTWARDS VANE
631 ;; OMEGA-UNDERBAR OMEGA UNDERBAR
632 ;; QUAD Q U A D
633 ;; QUAD-BACKSLASH QUAD BACKSLASH
634 ;; QUAD-CIRCLE QUAD CIRCLE
635 ;; QUAD-COLON QUAD COLON
636 ;; QUAD-DEL QUAD DEL
637 ;; QUAD-DELTA QUAD DELTA
638 ;; QUAD-DIAMOND QUAD DIAMOND
639 ;; QUAD-DIVIDE QUAD DIVIDE
640 ;; QUAD-DOWN-CARET QUAD DOWN CARET
641 ;; QUAD-DOWNWARDS-ARROW QUAD DOWNWARDS ARROW
642 ;; QUAD-EQUAL QUAD EQUAL
643 ;; QUAD-GREATER-THAN QUAD GREATER THAN
644 ;; QUAD-JOT QUAD JOT
645 ;; QUAD-LEFTWARDS-ARROW QUAD LEFTWARDS ARROW
646 ;; QUAD-LESS-THAN QUAD LESS THAN
647 ;; QUAD-NOT-EQUAL QUAD NOT EQUAL
648 ;; QUAD-QUESTION QUAD QUESTION
649 ;; QUAD-RIGHTWARDS-ARROW QUAD RIGHTWARDS ARROW
650 ;; QUAD-SLASH QUAD SLASH
651 ;; QUAD-UP-CARET QUAD UP CARET
652 ;; QUAD-UPWARDS-ARROW QUAD UPWARDS ARROW
653 ;; QUOTE-QUAD QUOTE QUAD
654 ;; QUOTE-UNDERBAR QUOTE UNDERBAR
655 ;; RIGHTWARDS-VANE RIGHTWARDS VANE
656 ;; SEMICOLON-UNDERBAR SEMICOLON UNDERBAR
657 ;; SLASH-BAR SLASH BAR
658 ;; SQUISH-QUAD SQUISH QUAD
659 ;; STAR-DIAERESIS STAR DIAERESIS
660 ;; STILE-TILDE STILE TILDE
661 ;; TILDE-DIAERESIS TILDE DIAERESIS
662 ;; UP-CARET-TILDE UP CARET TILDE
663 ;; UP-SHOE-JOT UP SHOE JOT
664 ;; UP-TACK-DIAERESIS UP TACK DIAERESIS
665 ;; UP-TACK-JOT UP TACK JOT
666 ;; UP-TACK-OVERBAR UP TACK OVERBAR
667 ;; UPWARDS-VANE UPWARDS VANE
668 ;; ZILDE ZILDE
669
670
671
672
673 ;; (loop for code1 = 123 for code2 from 54 below 96
674 ;;       do (insert (make-char 'mule-unicode-0100-24ff code1 code2)))
675
676 ;; (font-lock-add-keywords nil (apl-letter-font-lock))
677 ;; (apl-letter-font-lock)
678
679 (defparameter *letter-regexp-format* "[^A-Za-z0-9]\\(%s\\)[^A-Za-z0-9]")
680
681 (defun apl-letter-font-lock ()
682   "
683 RETURN: A font-lock-keywords list mapping greek letter names 
684         to greek characters.
685 "
686   (when (<= 21 emacs-major-version)
687     (cons
688      `(,(format "[^-A-Za-z0-9]\\(%s\\)[^-A-Za-z]"  "QUAD")
689         (1 (progn (compose-region (match-beginning 1) (match-end 1)
690                                   ,(make-char 'mule-unicode-0100-24ff
691                                               124 53)
692                                   'decompose-region)
693                   nil)))
694      (let ((code1 123) (code2 (1- 54)))
695        (mapcan 
696         (lambda (letter) 
697           (incf code2)
698           (when letter
699             `((,(format *letter-regexp-format* letter)
700                 (1 (progn (compose-region (match-beginning 1) (match-end 1)
701                                           ,(make-char 'mule-unicode-0100-24ff
702                                                       code1 code2)
703                                           'decompose-region)
704                           nil))))))
705         *apl-letters*)))))
706
707
708
709 (defconstant *greek-letters*  
710   '( "alpha" "beta" "gamma" "delta" "epsilon" "zeta" "eta"
711     "theta" "iota" "kappa" "lambda" "mu" "nu" "xi" "omicron" "pi" 
712     "rho"  "terminalsigma" "sigma" "tau"
713     "upsilon" "phi" "chi" "psi" "omega" )
714   "The order of these strings is fixed by the encoding of greek-iso8859-7!")
715
716
717 (defun greek-letter-font-lock ()
718   "
719 RETURN: A font-lock-keywords list mapping greek letter names 
720         to greek characters.
721 "
722   (when (and (<= 21 emacs-major-version) (<= emacs-major-version 22))
723     (let ((maj 64) (min 96))
724       (mapcan 
725        (lambda (letter) 
726          (incf maj) (incf min)
727          `(
728            (,(format *letter-regexp-format* (upcase letter))
729              (1 (progn (compose-region (match-beginning 1) (match-end 1)
730                                        ,(make-char 'greek-iso8859-7 maj)
731                                        'decompose-region)
732                        nil)))
733            (,(format *letter-regexp-format* (downcase letter))
734              (1 (progn (compose-region (match-beginning 1) (match-end 1)
735                                        ,(make-char 'greek-iso8859-7 min)
736                                        'decompose-region)
737                        nil)))))
738        *greek-letters*))))
739
740
741 (defun tree-upcase-strings (tree)
742   (cond
743     ((stringp tree) (string-upcase tree))
744     ((consp tree) (cons (tree-upcase-strings (car tree))
745                         (tree-upcase-strings (cdr tree))))
746     (t tree)))
747
748
749 (defvar pretty-greek t)
750 (defvar *greek-flk* '())
751
752 (defun pretty-greek ()
753   "
754 Show LAMBDA keyword as a greek letter lambda in lisp source code.
755  (add-hook 'emacs-lisp-mode-hook 'pretty-greek)
756  (add-hook 'lisp-mode-hook       'pretty-greek)
757 "
758   (interactive)
759   (unless (and (boundp 'pretty-greek) (not pretty-greek))
760     (setf font-lock-keywords-case-fold-search nil)
761     (setf *greek-flk*
762           (sort (append (greek-letter-font-lock) (apl-letter-font-lock))
763                 (lambda (a b) (> (length (car a)) (length (car b))))))
764     (font-lock-add-keywords nil *greek-flk*)))
765
766
767 (defun cancel-pretty-greek ()
768   (interactive)
769   (font-lock-remove-keywords nil *greek-flk*))
770
771
772
773 ;; (dolist (item   (greek-letter-font-lock)) 
774 ;;   (insert (format "%S\n" item)))
775
776
777 ;; Most of them are available in Unicode.  You can use TeX notation to
778 ;; enter them with the TeX input method, e.g. \nabla -> [].
779 ;;
780 ;; You don't even need the font-lock if you're using Emacs Lisp, as Emacs
781 ;; is perfectly happy about using the characters directly in symbols.  I
782 ;; think this also works with clisp.
783
784
785 (defvar update-def-names t)
786 (defvar update-def-names-minimum-lines 20)
787
788 (defun def-name (def arg)
789   ;; (message "def-name %S %S" def arg)
790   (cond
791     ((atom arg) arg)
792     ((STRING-EQUAL (string* (first arg)) "SETF") arg)
793     (t (first arg)))) ;;def-name
794
795
796 (defun update-def-names (&optional verbose)
797   "
798 DO:      Update comments at the end of each defmacro,defun,defwhatever
799          that stands on serveral lines.
800 "
801   (interactive "*")
802   (when update-def-names
803     (let ((error-point nil))
804       (handler-case
805           (save-excursion
806             (goto-char (point-min))
807             (forward-sexp)
808             (while (< (point) (point-max))
809               (let ((start (point))
810                     end)
811                 (backward-sexp)
812                 (setq end (point))
813                 (let ((sexp (progn (when (looking-at "#!") (forward-line 1))
814                                    (sexp-at-point))))
815                   (when verbose
816                     (message "point:%6d --  sexp: %s" 
817                              (point) (if (consp sexp) (car sexp) sexp)))
818                   (forward-sexp)
819                   (when (and (< update-def-names-minimum-lines
820                                 (count-lines start end))
821                              (consp sexp)
822                              (symbolp (car sexp))
823                              (<= 3 (length (symbol-name (car sexp))))
824                              (STRING-EQUAL (symbol-name (car sexp)) "DEF"
825                                            (kw END1) 3))
826                     (delete-region (point) (progn (end-of-line) (point)))
827                     (insert (format ";;%s"
828                               (def-name (first sexp) (second sexp)))))))
829               (handler-case (forward-sexp)
830                 (scan-error (err) 
831                   (setq error-point (point))
832                   (message "signal 1 %S %S" 'scan-error err)
833                   (signal 'scan-error err)) )))
834         (error (err) 
835           (when error-point
836             (goto-char error-point)
837             (skip-to-next-sexp))
838           (message "signal 2 %S %S" (car err) (cdr err))
839           (signal (car err) (cdr err)))))))
840   
841
842 ;; ------------------------------------------------------------------------
843 ;; map-sexps
844 ;; ------------------------------------------------------------------------
845 ;; Applies a function on all s-exps from a lisp source file.
846 ;; 
847
848 (defun skip-comments ()
849   "
850 DO:     Move the point over spaces and lisp comments ( ;...\n or #| ... |# ),
851         in the current buffer.
852 RETURN: (not eof)
853 "
854   (interactive)
855   (let* ((data (header-comment-description-for-mode major-mode))
856          (comment-regexp (hcd-comment-regexp data))
857          (space-or-comment (format "\\(%s\\)\\|\\(%s\\)" 
858                              "[ \t\n\v\f\r]+"
859                              comment-regexp)) )
860     (unless data
861       (error "Don't know how to handle this major mode %S." major-mode))
862     (while (looking-at space-or-comment)
863       (goto-char (match-end 0)))
864     (< (point) (point-max))))
865
866
867 (defparameter *source-readtable*
868   (when (fboundp 'COPY-READTABLE)
869     (let ((rt (COPY-READTABLE nil)))
870       (SET-DISPATCH-MACRO-CHARACTER (cl-char ?#) (cl-char ?+)
871                                     (lambda (stream subchar arg)
872                                       `('\#+ ,(READ stream nil nil t)))
873                                     rt)
874       (SET-DISPATCH-MACRO-CHARACTER (cl-char ?#) (cl-char ?-)
875                                     (lambda (stream subchar arg)
876                                       `('\#- ,(READ stream nil nil t)))
877                                     rt)
878       rt)))
879
880 (defun cl-sexp-at-point ()
881   (let ((*READTABLE* *source-readtable*))
882     (READ-FROM-STRING
883      (buffer-substring-no-properties 
884       (progn (forward-sexp  1) (point))
885       (progn (forward-sexp -1) (point))))))
886
887 ;; (MAKE-PATHNAME :type "elc")
888 ;; (MERGE-PATHNAMES (mkpathname nil nil nil nil "elc" nil)
889 ;;                  (mkpathname nil nil nil nil nil nil) nil)
890 ;; (LOAD "/home/pjb/src/public/lisp/common-lisp/source.lisp")
891 ;; 
892 ;; (PATHNAME  (mkpathname nil nil nil nil nil nil))
893 ;; (merge-directories nil nil)
894
895
896 (defvar *map-sexps-top-level* nil "Private")
897 (defvar *map-sexps-deeply*    nil "Private")
898 (defvar *map-sexps-atoms*     nil "Private")
899 (defvar *map-sexps-function*  nil "Private")
900
901
902 (defvar *walk-sexps-end-marker* nil)
903
904 (defun walk-sexps (fun)
905   "
906 DO:     Recursively scan sexps from (point) in current buffer up to 
907         the end-of-file or until scan-sexps raises a scan-error. 
908         Call fun on each sexps and each of their children etc.
909 fun:    A function (sexp start end) 
910         sexp:    The sexp parsed from a source file.
911         start:   The point starting the sexp.
912         end:     The point ending the sexp.
913 NOTE:   All positions are kept in markers, so modifying the buffer between 
914         start and end should be OK.
915         However  ' or ` are passed as (quote ...) or (backquote ...) 
916         to the function fun without reparsing the sexp inside them. 
917         Ie. if you modify such a source, (which can be detected looking at 
918         the character at start position),  you still get the original sexp.
919 "
920   (let ((quote-stack '())
921         (start-stack '())
922         (*walk-sexps-end-marker* (make-marker))
923         quote-depth
924         start-m sexp)
925     (skip-comments)
926     (while (/= (point) (point-max))
927       (when (member major-mode *lisp-modes*)
928         ;; gather the quotes:
929         (while (looking-at "['`] *")
930           ;; quote or backquote
931           ;; NOT NEEDED ANYMORE WITH GNU Emacs 21.
932           ;; --- (push (set-marker (make-marker) (point)) start-stack)
933           ;; --- (push (if (= (char-after) ?') 'quote 'backquote) quote-stack)
934           (forward-char 1)
935           (skip-comments)))
936       ;; get the sexp:
937       (setq start-m (set-marker (make-marker) (point)))
938       (forward-sexp 1)
939       (set-marker *walk-sexps-end-marker* (point))
940       ;; (forward-sexp -1)
941       ;; (assert (= (marker-position start-m) (point)) t)
942       (goto-char (marker-position start-m))
943       (setq sexp (cl-sexp-at-point))
944       ;; push the quotes on the sexp:
945       (setq quote-depth (length quote-stack))
946       (while quote-stack 
947         (setq sexp (cons (pop quote-stack) (list sexp))))
948       ;; process the quotes:
949       (setq start-stack (nreverse start-stack))
950       (dotimes (i quote-depth)
951         (message "sexp = %S\nstart = %S\nend = %S\n" sexp (marker-position (car start-stack)) *walk-sexps-end-marker*)
952         (funcall fun sexp 
953                  (marker-position (car start-stack)) *walk-sexps-end-marker*)
954         (set-marker (pop start-stack) nil)
955         (setq sexp (cadr sexp)))
956       ;; process the sexp:
957       (message "sexp = %S\nstart = %S\nend = %S\n" sexp  (marker-position start-m) *walk-sexps-end-marker*)
958       (funcall fun sexp (marker-position start-m)  *walk-sexps-end-marker*)
959       (when *map-sexps-deeply*
960         (when (= (char-syntax (char-after (marker-position start-m))) 40) ;; "("
961           ;; then the subsexps:
962           (goto-char (marker-position start-m))
963           (down-list 1)
964           (loop
965              (condition-case nil
966                  (walk-sexps fun)
967                (scan-error (return-from nil))))
968           (up-list 1)))
969       ;; then go to the next sexp:
970       (goto-char (marker-position *walk-sexps-end-marker*))
971       (set-marker start-m nil)
972       (set-marker *walk-sexps-end-marker* nil)))
973   nil)
974
975
976
977 (defun map-sexps-filter (sexp start end)
978   (when (and (or *map-sexps-top-level* *map-sexps-deeply*)
979              (or *map-sexps-atoms* (not (atom sexp))))
980     (funcall *map-sexps-function* sexp start end))
981   (setq *map-sexps-top-level* nil))
982
983 (defun new-map-sexps (source-file fun &rest cl-keys)
984    "
985 DO:     Scan all sexps in the source file. 
986         (skipping spaces and comment between top-level sexps).
987         If the deeply flag is set, 
988         then subsexps are also passed to the function fun, after the sexp,
989         else only the top-level sexps are 
990         If the atoms flags is set
991         then atoms are also considered (and passed to the selector).
992 fun:    A function (sexp start end) 
993         sexp:    The sexp parsed from a source file.
994         start:   The point starting the sexp.
995         end:     The point ending the sexp.
996 KEYS:   :deeply   (boolean,  default nil)
997         :atoms    (boolean,  default nil)
998 NOTE:   Scanning stops as soon as an error is detected by forward-sexp.
999 RETURN: The list of results from fun.
1000 "
1001   (cl-parsing-keywords ((:deeply   t)
1002                         (:atoms    nil)) nil
1003     
1004     
1005     ))
1006
1007 (defun new-map-sexps (source-file fun &rest cl-keys)
1008    "
1009 DO:     Scan all sexps in the source file. 
1010         (skipping spaces and comment between top-level sexps).
1011         If the deeply flag is set, 
1012         then subsexps are also passed to the function fun, after the sexp,
1013         else only the top-level sexps are 
1014         If the atoms flags is set
1015         then atoms are also considered (and passed to the selector).
1016 fun:    A function (sexp start end) 
1017         sexp:    The sexp parsed from a source file.
1018         start:   The point starting the sexp.
1019         end:     The point ending the sexp.
1020 KEYS:   :deeply   (boolean,  default nil)
1021         :atoms    (boolean,  default nil)
1022 NOTE:   Scanning stops as soon as an error is detected by forward-sexp.
1023 RETURN: The list of results from fun.
1024 "
1025   (cl-parsing-keywords ((:deeply   t)
1026                         (:atoms    nil)) nil
1027     
1028     `(source-text:map-source-file ,fun ,source-file
1029                                  :deeply ,cl-deeply
1030                                  :atoms ,cl-atoms)
1031     
1032     ))
1033
1034 (defun map-sexps (source-file fun &rest cl-keys)
1035   "
1036 DO:     Scan all sexps in the source file. 
1037         (skipping spaces and comment between top-level sexps).
1038         If the deeply flag is set, 
1039         then subsexps are also passed to the function fun, after the sexp,
1040         else only the top-level sexps are 
1041         If the atoms flags is set
1042         then atoms are also considered (and passed to the selector).
1043 fun:    A function (sexp start end) 
1044         sexp:    The sexp parsed from a source file.
1045         start:   The point starting the sexp.
1046         end:     The point ending the sexp.
1047 KEYS:   :deeply   (boolean,  default nil)
1048         :atoms    (boolean,  default nil)
1049 NOTE:   Scanning stops as soon as an error is detected by forward-sexp.
1050 RETURN: The list of results from fun.
1051 "
1052   (error "Doesn't work, need re-implementation; see new-map-sexps.")
1053   (cl-parsing-keywords ((:deeply   nil)
1054                         (:atoms    nil)) ()
1055     (message "map-sexps deeply %S  atoms %S" cl-deeply cl-atoms)
1056     (save-excursion
1057       (save-restriction
1058         (let ((old-buffer            (current-buffer))
1059               (existing-buffer       (buffer-named source-file))
1060               (*map-sexps-deeply*    cl-deeply)
1061               (*map-sexps-atoms*     cl-atoms)
1062               (*map-sexps-top-level* t)
1063               (*map-sexps-function*  fun)
1064               last-bosexp)
1065           (if existing-buffer
1066               (switch-to-buffer existing-buffer)
1067               (find-file source-file))
1068           (widen)
1069           (goto-char (point-min))
1070           (while (< (point) (point-max))
1071             (setq *map-sexps-top-level* t)
1072             (walk-sexps (function map-sexps-filter)))
1073           (if existing-buffer
1074               (switch-to-buffer old-buffer)
1075               (kill-buffer (current-buffer))))))))
1076
1077
1078 (defun old-old-map-sexps (source-file fun)
1079   "
1080 DO:     Scan all top-level sexps in the source file. 
1081         (skipping spaces and comment between top-level sexps).
1082 fun:    A function (sexp start end) 
1083         sexp:    The sexp parsed from a source file.
1084         start:   The point starting the sexp.
1085         end:     The point ending the sexp.
1086 :deeply         
1087 NOTE:   Scanning stops as soon as an error is detected by forward-sexp.
1088 RETURN: The list of results from fun.
1089 "
1090   (save-excursion
1091     (save-restriction
1092       (let ((old-buffer (current-buffer))
1093             (existing-buffer (buffer-named source-file))
1094             last-bosexp)
1095         (if existing-buffer
1096             (switch-to-buffer existing-buffer)
1097             (find-file source-file))
1098         (widen)
1099         (goto-char (point-max))
1100         (forward-sexp -1)
1101         (setq last-bosexp (point))
1102         (goto-char (point-min))
1103         (prog1
1104             (loop with eof  = (gensym)
1105                while (<= (point) last-bosexp)
1106                for end   = (progn (forward-sexp 1)  (point))
1107                for start = (progn (forward-sexp -1) (point))
1108                for sexp  = (condition-case nil (sexp-at-point) (error eof))
1109                until (eq eof sexp)
1110                collect (funcall fun sexp start end) into map-sexps-result
1111                do (condition-case nil 
1112                       (forward-sexp 1)
1113                     (error               (goto-char (point-max)))
1114                     (wrong-type-argument (goto-char (point-max))))
1115                finally (unless existing-buffer (kill-buffer source-file))
1116                finally return (nreverse map-sexps-result))
1117           (switch-to-buffer old-buffer))))))
1118
1119
1120 (defun count-sexps ()
1121   (interactive)
1122   (save-excursion
1123     (goto-char (point-min))
1124     (let ((place (point))
1125           (count 0))
1126       (forward-sexp)
1127       (while (< place (point))
1128         (incf count)
1129         (setq place (point))
1130         (forward-sexp))
1131       (message "There are %d top-level sexps." count)
1132       count))) ;;count-sexps
1133
1134 ;; ------------------------------------------------------------------------
1135 ;; get-sexps
1136 ;; ------------------------------------------------------------------------
1137 ;; Read all s-exps from a lisp source file. Can filter s-exps by a given
1138 ;; selector function.
1139 ;;
1140
1141 (defun get-sexps (source-file &rest cl-keys)
1142   "
1143 KEYS:    :selector (function: sexp --> boolean, default: (lambda (s) t))
1144          :deeply   (boolean,  default nil)
1145          :atoms    (boolean,  default nil)
1146 DO:      Scan all sexp in the source-file.  
1147          A selector function may indicate which sexp must be collected. 
1148          If the deeply flag is set, 
1149          then if a sexp is not selected then sub-sexp are scanned and tested.  
1150          If the atoms flags is set
1151          then atoms are also considered (and passed to the selector).
1152 NOTE:    Scanning stops as soon as an error is detected by forward-sexp.
1153 RETURN:  A list of selected sexp.
1154 "
1155   (save-excursion
1156     (cl-parsing-keywords ((:selector (function (lambda (s) t))) 
1157                           (:deeply   nil)
1158                           (:atoms    nil)) nil
1159       (let ((get-sexps-result '()))
1160         (map-sexps 
1161          source-file 
1162          (lambda (sexp start end)
1163            (when (funcall cl-selector sexp)
1164              (push sexp get-sexps-result)))
1165          :deeply cl-deeply :atoms cl-atoms)
1166         (nreverse get-sexps-result)))))
1167
1168
1169 ;;; (show
1170 ;;;  (sort
1171 ;;;   (let ((histo (make-hash-table)) (max-lisp-eval-depth 1000))
1172 ;;;     (mapc (lambda (path)
1173 ;;;             (message path)
1174 ;;;             (mapcar (lambda (sexp) (incf (gethash (depth sexp) histo 0)))
1175 ;;;                     (get-sexps path)))
1176 ;;;           (directory "~/src/common/lisp/emacs/[a-z]*.el"))
1177 ;;;     (let ((result '()))
1178 ;;;       (maphash (lambda (deep value) (push (cons deep value) result)) histo)
1179 ;;;       result))
1180 ;;;   (lambda (a b) (< (car a) (car b))))
1181 ;;;  )
1182 ;;; 
1183 ;;; ==> ((1 . 325) (2 . 329) (3 . 231) (4 . 163) (5 . 138) (6 . 158) (7 .
1184 ;;; 102) (8 . 94) (9 . 63) (10 . 40) (11 . 16) (12 . 20) (13 . 9) (14 . 4)
1185 ;;; (15 . 5) (16 . 4) (17 . 2) (19 . 2) (23 . 1))
1186
1187
1188
1189 ;; (defun old-get-sexps (source-file &rest cl-keys)
1190 ;;   "
1191 ;; KEYS:    :selector (a function, default: true)
1192 ;;          :deeply   (a boolean,  default nil)
1193 ;;          :atoms    (a boolean,  default nil)
1194 ;; DO:      Scan all sexp in the source-file.  
1195 ;;          A selector function (sexp->bool) may indicate which sexp must 
1196 ;;          be collected.  If the deeply flag is set, then if a sexp is not
1197 ;;          selected then sub-sexp are scanned and tested.  If the atoms flags 
1198 ;;          is set then atoms are also considered (and passed to the selector).
1199 ;; NOTE:    Scanning stops as soon as an error is detected by forward-sexp.
1200 ;; RETURN:  A list of selected sexp.
1201 ;; "
1202 ;;   (cl-parsing-keywords ((:selector (function identity)) 
1203 ;;                         (:deeply   nil)
1204 ;;                         (:atoms    nil)) nil
1205 ;;     (save-excursion
1206 ;;       (save-restriction
1207 ;;         (let ((existing-buffer (buffer-named source-file)))
1208 ;;           (if existing-buffer
1209 ;;               (set-buffer existing-buffer)
1210 ;;               (find-file source-file))
1211 ;;           (widen)
1212 ;;           (goto-char (point-min))
1213 ;;           (loop with result = nil
1214 ;;              while (/= (point) (point-max))
1215 ;;              for sexp = (condition-case nil (sexp-at-point) (error nil))
1216 ;;              do (flet ((deeply-select 
1217 ;;                            (sexp)
1218 ;;                          (if (atom sexp)
1219 ;;                              (if (and cl-atoms (funcall cl-selector sexp))
1220 ;;                                  (push sexp result))
1221 ;;                              (let (subsexp)
1222 ;;                                (while sexp
1223 ;;                                  (if (consp sexp) 
1224 ;;                                      (setq subsexp (car sexp)
1225 ;;                                            sexp    (cdr sexp))
1226 ;;                                      (setq subsexp sexp
1227 ;;                                            sexp    nil))
1228 ;;                                  (cond
1229 ;;                                    ((atom subsexp)
1230 ;;                                     (if (and cl-atoms 
1231 ;;                                              (funcall cl-selector subsexp))
1232 ;;                                         (push subsexp result)))
1233 ;;                                    ((funcall cl-selector subsexp)
1234 ;;                                     (push subsexp result))
1235 ;;                                    (cl-deeply
1236 ;;                                     (deeply-select subsexp))))))))
1237 ;;                   (if (atom sexp)
1238 ;;                       (if (and cl-atoms (funcall cl-selector sexp))
1239 ;;                           (push sexp result))
1240 ;;                       (cond
1241 ;;                         ((funcall cl-selector sexp)
1242 ;;                          (push sexp result))
1243 ;;                         (cl-deeply
1244 ;;                          (deeply-select sexp)))))
1245 ;;              (condition-case nil 
1246 ;;                  (forward-sexp 1) 
1247 ;;                (error (goto-char (point-max)))
1248 ;;                (wrong-type-argument (goto-char (point-max))))
1249 ;;              finally (unless existing-buffer (kill-buffer source-file))
1250 ;;              finally return (nreverse result))
1251 ;;           ))))
1252 ;;   ) ;;old-get-sexps
1253
1254
1255
1256 ;; ------------------------------------------------------------------------
1257 ;; replace-sexps
1258 ;; ------------------------------------------------------------------------
1259 ;; Applies a transformer function to all s-exps from a lisp source file,
1260 ;; replacing them by the result of this transformer function in the source file.
1261 ;;
1262
1263 ;;; TODO: Use CLISP to pretty print, or find an elisp pretty printer.
1264 ;;; "(LET ((*PRINT-READABLY* T))
1265 ;;;    (SETF (READTABLE-CASE *READTABLE*) :PRESERVE) 
1266 ;;;    (WRITE (QUOTE ~S )))"
1267
1268
1269 (defun replace-sexps (source-file transformer &rest cl-keys)
1270   "
1271 DO:             Scan all sexp in the source-file.
1272                 Each sexps is given to the transformer function whose result 
1273                 replaces the original sexps in the source-file.
1274                 If the deeply flag is set, then the transformer is applied 
1275                 recursively to the sub-sexps.
1276                 If the atoms flags is set then atoms are also considered 
1277                 (and passed to the transformer).
1278 KEYS:           :deeply    (a boolean,  default nil)
1279                 :atoms     (a boolean,  default nil)
1280 transformer:    A function sexp --> sexp.
1281                 If returing its argument (eq),
1282                 then no replacement takes place (the comments and formating
1283                 is then preserved.  Otherwise the source of the sexp is 
1284                 replaced by the returned sexp.  
1285 NOTE:           For now, no pretty-printing is done.
1286 "
1287   (cl-parsing-keywords ((:deeply   nil)
1288                         (:atoms    nil)) nil
1289     (map-sexps 
1290      source-file 
1291      (lambda (sexp start end)
1292        (let ((replacement (funcall transformer sexp)))
1293          (unless (eq replacement sexp)
1294            (delete-region start end)
1295            (insert (let ((print-escape-newlines t)
1296                          (print-level nil)
1297                          (print-circle nil)
1298                          (print-length nil)) (format "%S" replacement)))
1299            (set-marker end (point)))))
1300      :deeply cl-deeply :atoms cl-atoms))
1301   nil)
1302
1303
1304
1305 ;; ------------------------------------------------------------------------
1306 ;; clean-if*
1307 ;; ------------------------------------------------------------------------
1308 ;; Replace if* by if, when, unless or cond.
1309 ;;
1310
1311 (defun escape-sharp ()
1312   (interactive)
1313   (save-excursion
1314     (goto-char (point-min))
1315     (while
1316         (re-search-forward "\\(#\\([^A-Za-z0-9()\\\\ ]\\|\\\\.\\)*\\)" nil t)
1317       (let* ((match (match-string 1))
1318              (escap (base64-encode-string match t)))
1319         (replace-match (format "|ESCAPED-SHARP:%s|" escap) t t)))))
1320
1321
1322 ;;; (let ((s "toto #.\\( titi"))
1323 ;;; (string-match  "\\(#\\(\\\\.\\|[^A-Za-z0-9()\\\\ ]\\)*\\)" s)
1324 ;;; (match-string 1 s))
1325
1326
1327
1328 (defun unescape-sharp ()
1329   (interactive) 
1330   (save-excursion
1331     (goto-char (point-min))
1332     (while (re-search-forward
1333             "\\(|ESCAPED-SHARP:\\([A-Za-z0-9+/=*]*\\)|\\)" nil t)
1334       (let* ((escap (match-string 2))
1335              (match (base64-decode-string escap)))
1336         (replace-match match t t nil 1)))))
1337
1338
1339 (defun clean-if* ()
1340   (interactive "*")
1341   (escape-sharp)
1342   (unwind-protect
1343        (replace-sexps
1344         (buffer-file-name)
1345         (lambda (sexp)
1346           (message "sexp=%S" sexp )
1347           (let ((backquoted (eql '\` (car sexp)))
1348                 (original-sexp sexp))
1349             (when backquoted (setq sexp (second sexp)))
1350             (if (and (consp sexp) (symbolp (car sexp)) 
1351                      (STRING-EQUAL 'IF* (car sexp)))
1352                 (do* ((subs (cons 'ELSEIF (cdr sexp)))
1353                       (clauses '())
1354                       (condition)
1355                       (statements)
1356                       (token))
1357                      ((null subs)
1358                       (let ((result
1359                              (progn ;;generate the new sexp
1360                                (setq clauses (nreverse clauses))
1361                                (cond
1362                                  ((and (= 1 (length clauses))
1363                                        (every 
1364                                         (lambda (clause) (not (null (cdr clause))))
1365                                         ;; clause = (cons condition statements)
1366                                         clauses)) ;; a when
1367                                   `(when ,(car (first clauses)) 
1368                                      ,@(cdr (first clauses))))
1369                                  ((or (= 1 (length clauses))
1370                                       (< 2 (length clauses))
1371                                       (not (eq t (car (second clauses))))) ;; a cond
1372                                   `(cond ,@clauses))
1373                                  (t ;; a if
1374                                   `(if ,(car (first clauses))
1375                                        ,(if (= 1 (length (cdr (first clauses))))
1376                                             (cadr (first clauses))
1377                                             `(progn ,@(cdr (first clauses))))
1378                                        ,(if (= 1 (length (cdr (second clauses))))
1379                                             (cadr (second clauses))
1380                                             `(progn ,@(cdr (second clauses)))))))) ))
1381                         (message "sexp=%S\nresult=%S" sexp result)
1382                         (if backquoted (list '\` result) result)))
1383                   ;; read the condition:
1384                   (setq token (pop subs))
1385                   (cond
1386                     ((not (symbolp token))
1387                      (error "unexpected token %S in %S" token sexp))
1388                     ((null subs)
1389                      (error "unexpected end of sexp in %S" sexp))
1390                     ((STRING-EQUAL token 'ELSEIF)
1391                      (setq condition (pop subs))
1392                      (unless (or (STRING-EQUAL (car subs) 'THEN)
1393                                  (STRING-EQUAL (car subs) 'THENRET))
1394                        (error "missing THEN after condition in %S" sexp))
1395                      (pop subs))
1396                     ((STRING-EQUAL token 'ELSE)
1397                      (setq condition t))
1398                     (t
1399                      (error "unexpected token %S in %S" token sexp)))
1400                   ;; read the statements:
1401                   (do () ((or (null subs)  
1402                               (and (consp subs) (symbolp (car subs))
1403                                    (member* (car subs) '(ELSEIF ELSE)
1404                                              :test (function STRING-EQUAL)))))
1405                     (push (pop subs) statements))
1406                   (push (cons condition (nreverse statements)) clauses)
1407                   (setq condition nil statements nil))
1408                 original-sexp)))
1409         :deeply t :atoms nil)
1410     (unescape-sharp)))
1411
1412
1413
1414 ;; ------------------------------------------------------------------------
1415 ;; pjb-defclass
1416 ;; ------------------------------------------------------------------------
1417 ;; Syntactic sugar for defclass
1418 ;;
1419
1420 ;; (defmacro pjb-attrib (name type &rest args)
1421 ;;   "
1422 ;; This macro outputs an attribute s-exp as used in defclass.
1423 ;; ARGS  may be of length 1 or 2.
1424 ;;       If (LENGTH ARGS) = 1 
1425 ;;       then if the argument is a string, 
1426 ;;            then it's taken as the documentation and the initial value is NIL
1427 ;;            else it's taken as the initial value and the documentation is NIL.
1428 ;;       else the first is the initial value and the second is the documentation.
1429 ;; The initarg an accessor are the same keyword built from the name.
1430 ;; "
1431 ;;   (let ((iarg (intern (format ":%s" name)))
1432 ;;         init doc)
1433 ;;     (cond 
1434 ;;       ((= 2 (length args))
1435 ;;        (setq init (car  args)
1436 ;;              doc  (cadr args)) )
1437 ;;       ((= 1 (length args))
1438 ;;        (if (stringp (car args))
1439 ;;            (setq init nil
1440 ;;                  doc  (car args))
1441 ;;            (setq init (car args)
1442 ;;                  doc  nil)) )
1443 ;;       (t (error "Invalid arguments to pjb-attrib.")))
1444 ;;     (if (and (symbolp type) (null init))
1445 ;;         (setq type (list 'or 'null type)))
1446 ;;     (if (null doc)
1447 ;;         (setq doc (symbol-name name)))
1448 ;;     `(,name 
1449 ;;       :initform ,init 
1450 ;;       :initarg  ,iarg
1451 ;;       :accessor ,name
1452 ;;       :type     ,type
1453 ;;       :documentation ,doc)
1454 ;;     )) ;;pjb-attrib
1455
1456
1457 (defmacro pjb-defclass (name super &rest args)
1458   "
1459 This macro encapsulate DEFCLASS and allow the declaration of the attributes
1460 in a shorter syntax.
1461 ARGS  is a list of s-expr, whose car is either :ATT (to declare an attribute)
1462       or :DOC to give the documentation string of the class.
1463       (:OPT is not implemented yet).
1464       See PJB-ATTRIB for the syntax of the attribute declation.
1465       (:ATT name type [ init-value [doc-string] | doc-string ] )
1466 "
1467   (let ((fields  nil)
1468         (options nil))
1469     (while args
1470       (cond ((eq :att (caar args))
1471              (push (macroexpand (cons 'pjb-attrib (cdar args))) fields))
1472             ((eq :doc (caar args))
1473              (push (cons :documentation (cdar args)) options))
1474             )
1475       (setq args (cdr args)))
1476     (setq fields (nreverse fields))
1477     (setq options (nreverse options))
1478     `(defclass ,name ,super ,fields ,options)))
1479
1480
1481 ;; ------------------------------------------------------------------------
1482 ;; karnaugh & karnaugh-solve
1483 ;; ------------------------------------------------------------------------
1484 ;; karnaugh: Displays a truth table either to be edited of with computed actions.
1485 ;; karnaugh-solve: Generate functions for the actions given as a thuth table.
1486 ;;
1487
1488
1489 (defun integer-to-bool-list (n &rest cl-keys)
1490   "
1491 PRE:     n>=0
1492 RETURN:  The list of the binary digits of n, from the least significant.
1493 "
1494   (cl-parsing-keywords (:length) nil
1495     (unless (integerp n)
1496       (error "Argument must be integer, not %S." n))
1497     (when (< n 0) 
1498       (setq n (abs n)))
1499     (if cl-length
1500         (loop for m = n then (/ m 2)
1501            for i from 0 below cl-length
1502            collect (/= 0 (mod m 2)) into digits
1503            finally return digits)
1504         (loop for m = n then (/ m 2)
1505            while (< 0 m)
1506            collect (/= 0 (mod m 2)) into digits
1507            finally return digits))))
1508
1509
1510 ;;; (insert (karnaugh '(a b c d e) 
1511 ;;;                 '(( do-1 . (lambda (a b c d e) (and a (or b c)))) 
1512 ;;;                   ( do-2 . (lambda (a b c d e) (or (not a) b)))
1513 ;;;                   ( do-3 . (lambda (a b c d e) (and (not a) b (not c)))))
1514 ;;;                 '(FAUX . VRAI)))
1515
1516 ;;; (show
1517 ;;; (karnaugh-solve '(a b) '(carry sum)
1518 ;;;                           '(( 0 0  0 0)
1519 ;;;                             ( 0 1  0 1)
1520 ;;;                             ( 1 0  0 1)
1521 ;;;                             ( 1 1  1 0)) 
1522 ;;;                           '( 0 . 1))
1523 ;;; )
1524
1525 ;;; (insert (karnaugh '(a b c) 
1526 ;;;                 '((action . (lambda (a b c) 
1527 ;;;                               (or (and a (and b (not c)))
1528 ;;;                                   (or (and (not a) (and b (not c)))
1529 ;;;                                       (or (and (not a) c)
1530 ;;;                                           (and (not b) c)))))))
1531 ;;;                 '(F . T)))
1532
1533
1534 (defun karnaugh-solve (conditions actions table &optional bool-vals action-vals)
1535   "
1536 DO:         Finds an expression for each actions,
1537             in function of the conditions, given the truth table.
1538 conditions: A list of symbols or symbol names.
1539             Since the conditions are used as argument name for the expressions,
1540             it may not contain reserved symbols such as t.
1541 actions:    A list of symbols or symbol names.
1542 table:      Each line of the table is a list
1543             with the truth value of all conditions
1544             followed by the truth value of all actions.
1545             Missing combinations are deemed false for all actions.
1546 bool-vals   Specifies the atoms used as truth values
1547             for the conditions. Default is (NO . YES).
1548 action-vals Specifies the atoms used as truth values
1549             for the actions. Default is bool-vals.
1550 PRE:        for each line in table,
1551                (= (length line) (+ (length conditions) (length actions))).
1552 RETURN:     A list of cons (action . (lambda (conditions) expression)).
1553 EXAMPLE:    (karnaugh-solve '(a b) '(carry sum)
1554                           '(( 0 0  0 0)
1555                             ( 0 1  0 1)
1556                             ( 1 0  0 1)
1557                             ( 1 1  1 0)) 
1558                           '( 0 . 1))
1559             ==> ((carry . (lambda (a b) (and a b)))
1560                  (sum   . (lambda (a b) (or (and a (not b)) (and (not a) b)))))
1561 NOTE:       Current implementation does not simplify the expressions.
1562 SEE ALSO:   `karnaugh' and `gentable'.
1563 "
1564   (when (null bool-vals)
1565     (setq bool-vals '(NO . YES)))
1566   (when (null action-vals)
1567     (setq action-vals bool-vals))
1568   (setq conditions (mapcar (lambda (item)
1569                              (if (stringp item)
1570                                  (intern item) item)) conditions))
1571   (setq actions (mapcar (lambda (item)
1572                           (if (stringp item)
1573                               (intern item) item)) actions))
1574   (let* ((c-no    (car bool-vals))
1575          (c-yes   (cdr bool-vals))
1576          (a-no    (car action-vals))
1577          (a-yes   (cdr action-vals))
1578          (i       (length conditions))
1579          (act-ind (mapcar (lambda (action) 
1580                             (prog1 (list action i) (setq i (1+ i))))
1581                           actions)))
1582     (mapc (lambda (line)
1583             (mapc (lambda (action)
1584                     (if (eq a-yes (nth (cadr action) line))
1585                         (nconc action (list line))))
1586                   act-ind))
1587           table)
1588     (mapcar 
1589      (lambda (action)
1590        (cons (car action)
1591              (list 'lambda conditions 
1592                    (cons 'or 
1593                          (mapcar
1594                           (lambda (line)
1595                             (cons 'and
1596                                   (mapcar*
1597                                    (lambda (cond-name cond-val)
1598                                      (if (eq c-yes cond-val)
1599                                          cond-name
1600                                          (list 'not cond-name)))
1601                                    conditions line)))
1602                           (cddr action))))))
1603      act-ind)))
1604
1605
1606
1607 (defun karnaugh (conditions actions &optional bool-vals action-vals)
1608   "
1609 DO:           Generates a truth table for all combinations of the conditions.
1610 conditions:   A list of strings or symbols.
1611 actions:      A list of actions. An action can be a string or a symbol,
1612               or a cons whose car is a string or a symbol (the name of the
1613               action) and whose cdr is a lambda taking as arguments boolean
1614               values for the conditions, and returning a boolean value for
1615               the action.
1616               If such a function for an action is given, it's used to
1617               compute the cases when the action must be run.
1618 bool-vals     A cons of symbol or string (false . true) used as values for the
1619               conditions.
1620 action-vals   A cons of symbol or string (false . true) used as values for the
1621               actions.
1622 SEE ALSO:     `karnaugh-solve' and `gentable'.
1623 "
1624   (when (null bool-vals)
1625     (setq bool-vals '("NO" . "YES")))
1626   (when (null action-vals)
1627     (setq action-vals '("·" . "×")))
1628   (when (symbolp (car bool-vals))
1629     (setf (car bool-vals) (symbol-name (car bool-vals))))
1630   (when (symbolp (cdr bool-vals))
1631     (setf (cdr bool-vals) (symbol-name (cdr bool-vals))))
1632   (when (< 8 (length conditions))
1633     (error "Too many conditions."))
1634   (setq conditions (mapcar (lambda (item)
1635                              (if (stringp item) item (format "%s" item))) 
1636                            conditions))
1637   (let* ((size-bool-vals
1638           (max (length (car bool-vals)) (length (cdr bool-vals))))
1639          (c-count (length conditions))
1640          (a-count (length actions))
1641          (s-count (+ c-count a-count))
1642          (a-title 
1643           (mapcar (lambda (item)
1644                     (cond 
1645                       ((stringp item) item)
1646                       ((symbolp item) (symbol-name item))
1647                       ((consp item)
1648                        (cond 
1649                          ((stringp (car item)) (car item))
1650                          ((symbolp (car item)) (symbol-name (car item)))
1651                          (t (error "Invalid action %S." item)))
1652                        )
1653                       (t (error "Invalid action %S." item))))
1654                   actions))
1655          (a-indic (make-array (list a-count) 
1656                               :initial-contents (mapcar (lambda (item)
1657                                                           (if (consp item)
1658                                                               (cdr item) nil))
1659                                                         actions)))
1660          (a-complex (loop for i across a-indic until i finally return i))
1661          ;; whether a-indic contains at least one indicator.
1662          (sizes  
1663           (let ((sizes (make-array (list s-count))))
1664             (loop for cnd in conditions
1665                for i = 0 then (1+ i)
1666                do (setf (aref sizes i) (max size-bool-vals (length cnd))))
1667             (loop for act in a-title
1668                for i = c-count then (1+ i)
1669                do (setf (aref sizes i) (max 3 (length act))))
1670             sizes))
1671          (line-length 
1672           (loop for i from 0 below s-count
1673              sum  (+ 3 (aref sizes i)) into l
1674              finally return (1+ l)))
1675          (line 
1676           (loop with line = (make-string line-length (character "-"))
1677              for i from 0 below s-count
1678              for position = (+ (aref sizes i) 3) 
1679              then (+ position  (aref sizes i) 3)
1680              ;;do (printf "sizes=%S i=%d p=%d\n" sizes i position)
1681              do      (setf (aref line position) (character "+"))
1682              finally (setf (aref line 0) (character "+"))
1683              finally return line))
1684          (act-part 
1685           (if a-complex
1686               nil
1687               (loop for i from c-count below s-count
1688                  collect (concatenate 
1689                              'string
1690                            (make-string (+ 2 (aref sizes i)) (character " "))
1691                            "|")
1692                  into parts
1693                  finally return (apply 'concatenate 'string parts))))
1694          (new-line (make-string 1 (character 10))))
1695     ;;(printf "line-length=%d\n" line-length)
1696     (concatenate 'string 
1697       line new-line
1698       "|" 
1699       (loop for item in conditions
1700          for i from 0 below c-count
1701          collect (concatenate 'string 
1702                    " " (string-pad item (aref sizes i) :center) " |") 
1703          into title
1704          finally return (apply 'concatenate 'string title))
1705          
1706       (loop for item in a-title
1707          for i from c-count below s-count
1708          collect (concatenate 'string 
1709                    " " (string-pad item (aref sizes i) :center) " |") 
1710          into title
1711          finally return  (apply 'concatenate 'string title))
1712       new-line
1713       line new-line
1714       (loop for i from (1- (expt 2 c-count)) downto 0
1715          for conditions = (nreverse (integer-to-bool-list i :length c-count))
1716          collect (concatenate 'string 
1717                    ;; conditions
1718                    (loop 
1719                       for k from 0 below c-count
1720                       for c in conditions 
1721                       for l = (+ 3 (aref sizes k))
1722                       for s = (string-pad 
1723                                (if c (cdr bool-vals) (car bool-vals))
1724                                l :center)
1725                       do (setf (char s (1- l)) (character "|"))
1726                       collect s into items
1727                       finally return (apply 'concatenate 'string "|" items))
1728                    ;; actions
1729                    (if act-part
1730                        act-part
1731                        (loop 
1732                           for k from 0 below a-count
1733                           for l = (+ 3 (aref sizes (+ c-count k)))
1734                           for f = (aref a-indic k)
1735                           for s = (string-pad
1736                                    (if f (if (apply f conditions) 
1737                                              (cdr action-vals)
1738                                              (car action-vals)) "")
1739                                    l :center)
1740                           do (setf (char s (1- l)) (character "|"))
1741                           collect s into items
1742                           finally return (apply 'concatenate 'string items)))
1743                    new-line) into lines
1744          finally return (apply 'concatenate 'string lines))
1745       line new-line)))
1746
1747
1748
1749
1750 (defun combine (&rest args)
1751   "
1752 RETURN:  (elt args 0) x (elt args 1) x ... x (elt args (1- (length args)))
1753          = the set of tuples built taking one item in order from each list
1754            in args.
1755 EXAMPLE: (COMBINE '(WWW FTP) '(EXA) '(COM ORG))) 
1756            --> ((WWW EXA COM) (WWW EXA ORG) (FTP EXA COM) (FTP EXA ORG))
1757 "
1758   (cond
1759     ((null args) '(nil))
1760     ((consp (car args))
1761      (mapcan (lambda (item) (apply (function combine) item (cdr args)))
1762              (car args)))
1763     (t
1764      (mapcan (lambda (rest) (list (cons (car args) rest)))
1765              (apply (function combine) (cdr args))))))
1766
1767
1768 (defun compute-column-widths (rows)
1769   (if (or (null rows) (every (function null) rows))
1770       nil
1771       (cons (reduce (function max)
1772                     (mapcar (function length)
1773                             (mapcar (function car) rows)))
1774             (compute-column-widths (mapcar (function cdr) rows)))))
1775
1776
1777 (defmacro with-standard-output-to-string (&rest body)
1778   `(with-output-to-string ,@body))
1779
1780 ;;#+COMMON-LISP
1781 ;;(defmacro with-standard-output-to-string (&body body)
1782 ;;  `(with-output-to-string (*standard-output*) ,@body))
1783
1784
1785 (defun gentable (conditions actions)
1786   "Needs a better name.
1787   (gentable '((input  :stream :terminal nil)
1788               (output :stream :terminal nil)
1789               (wait   t nil))
1790             '((use (lambda (i o w) (and w (or (eq i :stream) (eq o :stream)))))
1791              result))
1792 "
1793   (setf conditions
1794         (delete* nil (mapcar
1795                      (lambda (c) (if (atom c) (cons c '(no yes)) c))
1796                      conditions)
1797                 :key (function cdr)))
1798   (setf actions
1799         (delete* nil (mapcar
1800                      (lambda (a) (if (atom a) (list a (lambda (&rest args) "")) a))
1801                      actions)
1802                 :key (function cdr)))
1803   (let* ((title
1804            (mapcar (lambda (x) (format "%s" x)) ;(format "%s" x))
1805                    (nconc (mapcar (function first) conditions)
1806                           (mapcar (function first) actions))))
1807          (rows
1808           (mapcar
1809            (lambda (conditions)
1810              (nconc (mapcar (lambda (x) (format "%s" x)) conditions)
1811                     (mapcar
1812                      (lambda (action)
1813                        (format "%s" 
1814                          (apply (cond
1815                                   ((symbolp (second action))
1816                                    (eval `(function ,(second action))))
1817                                   ((and (consp (second action))
1818                                         (eq 'lambda (first (second action))))
1819                                    (eval (second action)))
1820                                   ((functionp (second action))
1821                                    (second action))
1822                                   (t (error "What is it %S" action)))
1823                                 conditions)))
1824                      actions)))
1825            (apply (function combine) (mapcar (function cdr) conditions))))
1826          (widths (compute-column-widths (cons title rows)))
1827          (line (with-standard-output-to-string
1828                    (loop initially (princ "+")
1829                       for w in  widths
1830                       do (progn
1831                            (princ (make-string (+ 2 w) ?-))
1832                            (princ "+"))))))
1833     (with-standard-output-to-string
1834         (flet ((print-row (row)
1835                  (loop
1836                     initially (princ "|")
1837                     for item in row
1838                     for width in widths
1839                     do (progn
1840                          (princ (string-pad item (+ 2 width)
1841                                             :justification :center))
1842                          (princ "|")))
1843                  (terpri)))
1844           (loop
1845              initially (progn
1846                          (princ line) (terpri)
1847                          (print-row title)
1848                          (princ line) (terpri))
1849              for row in rows
1850              do (print-row row)
1851              finally (princ line) (terpri))))))
1852
1853
1854
1855 ;; ------------------------------------------------------------------------
1856 ;; SOURCE HEADER
1857 ;; ------------------------------------------------------------------------
1858 ;; Inserts and Edit the comment at the top of source files.
1859 ;; See the beginning of this file to have an example of such an header!
1860 ;;
1861
1862
1863
1864 ;; ------------------------------------------------------------------------
1865 ;; Extract, format, and update copyright lines.
1866 ;; ------------------------------------------------------------------------
1867
1868 (defun pjb-copyright-regexp (hcd)
1869   (let* ((comment-format (or (hcd-header-comment-format hcd) "%s"))
1870          (pattern  "Copyright ")
1871          (base-re  (format "^%s" (regexp-quote (format comment-format pattern))))
1872          (pos      (+ (search pattern base-re) (length pattern)))
1873          (left-re  (subseq base-re 0 pos))
1874          (right-re (subseq base-re pos)))
1875     (format "%s *\\(.*?\\) +\\([0-9]+\\)\\(\\( +-\\|,\\) +\\([0-9]+\\)\\)*\\( +-\\|,\\) +\\([0-9]+\\).*%s"
1876             left-re right-re)))
1877
1878
1879 (defun regexp-results (match string)
1880   (let ((data (match-data t)))
1881     (when data
1882       (coerce
1883        (loop
1884           for (beg end) on data by (function cddr)
1885           while (or (null beg) (integerp beg))
1886           collect (list beg end (when (and beg end) (subseq string (1- beg) (1- end)))))
1887        'vector))))
1888
1889
1890 (defun pjb-process-copyrights (hcd fun)
1891   "
1892 Call the function `fun' with  the beginning and end points of each
1893 copyright line, and a list containing the copyright owner, the first
1894 and last year of the copyright.
1895 "
1896   (let ((re   (pjb-copyright-regexp hcd))
1897         (text (buffer-substring-no-properties (point-min) (point-max))))
1898     (save-excursion
1899       (goto-char (point-min))
1900       (with-marker (end (point-max))
1901        (loop
1902           with next = (make-marker)
1903           while (re-search-forward re end t)
1904           do (let ((res (regexp-results t text)))
1905                (set-marker next (1+ (second (aref res 0))))
1906                (funcall fun
1907                         (first  (aref res 0))
1908                         (second (aref res 0))
1909                         (list (third (aref res 1))
1910                               (parse-integer (third (aref res 2)))
1911                               (parse-integer (third (aref res 7)))))
1912                (goto-char (1- (marker-position next)))))))))
1913
1914
1915 (defun pjb-extract-copyrights (hcd)
1916   (let ((pjb-extract-copyrights/result '()))
1917     (pjb-process-copyrights hcd
1918                             (lambda (start end copyright)
1919                               (declare (ignore start end))
1920                               (push copyright pjb-extract-copyrights/result)))
1921     (nreverse pjb-extract-copyrights/result)))
1922
1923 ;; (pjb-extract-copyrights  (header-comment-description-for-mode major-mode))
1924
1925
1926
1927 (defun pjb-format-copyright (hcd author first-year last-year)
1928   (let ((comment-format (hcd-header-comment-format hcd)))
1929    (format comment-format
1930            (format "Copyright %s %04d - %04d"
1931                    author first-year last-year))))
1932
1933
1934 (defun pjb-update-copyright ()
1935   "
1936 Update the copyright lines with the current year.
1937 NOTE:  only for Copyright Pascal Bourguignon.
1938 "
1939   (interactive)
1940   (let ((current-year  (third (calendar-current-date)))
1941         (hcd (header-comment-description-for-mode major-mode)))
1942     (pjb-process-copyrights
1943      hcd
1944      (lambda (start end copyright)
1945        (destructuring-bind (owner first-year last-year) copyright
1946          (declare (ignore last-year))
1947          (when (and (search "Pascal" owner)
1948                     (search "Bourguignon" owner))
1949            (delete-region start end)
1950            (insert (pjb-format-copyright hcd owner first-year current-year))))))))
1951
1952 (defvar *source-extensions*
1953   '(".lisp" ".cl" ".asd" ".el"
1954     "Makefile"
1955     ".c" ".cc" ".cpp" ".c++"
1956     ".h" ".hh" ".hpp" ".h++"
1957     ".m" ".mm"))
1958
1959 (defvar *ignorable-directories*
1960   '("_darcs" ".darcsrepo" ".svn" ".hg" ".git" "CVS" "RCS" "MT" "SCCS"
1961     ".tmp_versions" "{arch}" ".arch-ids"
1962     "BitKeeper" "ChangeSet" "autom4te.cache"))
1963
1964
1965 (defun pjb-update-copyright-directory ()
1966   (interactive)
1967   (let ((good-files-re      (format "\\(%s\\)$" (regexp-opt *source-extensions*)))
1968         (bad-directories-re (format "/%s$" (regexp-opt *ignorable-directories*))))
1969     (message "Updating copyright of all source files in %S" default-directory)
1970     (message "Source files: %s" (join *source-extensions* " "))
1971     (with-files (path default-directory t
1972                       (lambda (path)
1973                         ;; (message "filter %S --> %s" path  (string-match bad-directories-re path))
1974                         ;; (message "recursive %s stat %S" recursive stat)
1975                         (string-match bad-directories-re path)))
1976       (when (string-match good-files-re path)
1977         (with-file (path :save t :kill t :literal nil)
1978           (message "Updating copyright in file %S" path)
1979           (pjb-update-copyright))))))
1980
1981
1982
1983 ;; ------------------------------------------------------------------------
1984 ;; pjb-add-change-log-entry
1985 ;; ------------------------------------------------------------------------
1986 ;; Inserts a change log entry in the current source, 
1987 ;; and in the GNU-style ChangeLog file.
1988
1989 (defvar *pjb-sources-initials* nil 
1990   "Initials of the developer, to be inserted in MODIFICATIONS log entries
1991 by pjb-add-change-log-entry.")
1992
1993
1994 (defun hcd-justify-text (first-margin other-margin text)
1995   (let ((flen (length first-margin))
1996         (olen (length other-margin))
1997         (lines (split-string text "[\n\v\r\f]+")) )
1998     (cond
1999       ((null lines)          first-margin)
2000       ((= (length lines) 1) (concatenate 'string first-margin (car lines)))
2001       (t (when (< olen flen)
2002            (setq other-margin
2003                  (concatenate 'string other-margin
2004                               (make-string (- flen olen) (character " ")))))
2005          (apply (function concatenate)
2006                 'string
2007                 first-margin
2008                 (list-insert-separator 
2009                  lines  (concatenate 'string "\n" other-margin)))))))
2010
2011     
2012 (defun pjb-add-change-log-entry (&optional log-entry)
2013   (interactive "*")
2014   (widen)
2015   (goto-char (point-min))
2016   (let* ((data (header-comment-description-for-mode major-mode))
2017          (comment-format (hcd-header-comment-format data))
2018          (entry-head (format "%s <%s> " 
2019                        (funcall add-log-time-format)
2020                        (or *pjb-sources-initials*
2021                            (user-real-login-name)
2022                            add-log-full-name))))
2023     (unless data
2024       (error "Don't know how to handle this major mode %S." major-mode))
2025     (unless (re-search-forward "\\<MODIFICATIONS\\>" nil t)
2026       (error "Can't find the MODIFICATIONS section. Please add an header first."))
2027     (goto-char (match-end 0))
2028     (insert "\n")
2029     (if log-entry
2030         (dolist
2031             (line
2032               (mapcar (lambda (line) (format comment-format line))
2033                       (split-string
2034                        (hcd-justify-text entry-head entry-head log-entry)
2035                        "\n")))
2036           (insert line))
2037         (insert (format comment-format entry-head)))))
2038
2039
2040 (defun pjb-reformat-change-log-dates ()
2041   (interactive "*")
2042   (save-excursion
2043     (save-restriction
2044       (widen)
2045       (goto-char (point-min))
2046       (let* ((data (header-comment-description-for-mode major-mode))
2047              (comment-format (hcd-header-comment-format data))
2048              start end)
2049         (unless data
2050           (error "Don't know how to handle this major mode %S." major-mode))
2051         (unless (re-search-forward "\\<MODIFICATIONS\\>" nil t)
2052           (error "Can't find the MODIFICATIONS section. Please add an header first."))
2053         (setq start (match-end 0))
2054         (unless (re-search-forward "\\<BUGS\\|LEGAL\\>" nil t)
2055           (error "Can't find the LEGAL section. Please add an header first."))
2056         (setq end (match-beginning 0))
2057         (goto-char start)
2058         (while (re-search-forward "\\<\\([0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([0-9][0-9][0-9][0-9]\\)\\> <" end t)
2059           (replace-match 
2060            (format "%s-%s-%s <" 
2061              (match-string 3) (match-string 2) (match-string 1))))
2062         (goto-char start)
2063         (while (re-search-forward "\\<\\([0-9][0-9][0-9][0-9]\\)/\\([0-9][0-9]\\)/\\([0-9][0-9]\\)\\> <" end t)
2064           (replace-match 
2065            (format "%s-%s-%s <" 
2066              (match-string 1) (match-string 2) (match-string 3))))))))
2067
2068
2069 (defmacro format-insert (&rest form-args)
2070   `(progn ,@(mapcar (lambda (form-arg) `(insert (format ,@form-arg))) form-args)))
2071
2072
2073 (defun pjb-insert-package (pname)
2074   (interactive "sPackage name: ")
2075   (setq pname (string-upcase pname))
2076   (let ((nick (subseq pname (1+ (or (position (character ".") 
2077                                               pname :from-end t) -1)))))
2078     (format-insert
2079      ("(DEFINE-PACKAGE \"%s\"\n" pname)
2080      ("  ;;(:NICKNAMES \"%s\")\n" nick)
2081      ("  (:DOCUMENTATION \"\")\n")
2082      ("  (:FROM \"COMMON-LISP\"                           :IMPORT :ALL)\n")
2083      ("  (:FROM \"COM.INFORMATIMAGO.COMMON-LISP.UTILITY\" :IMPORT :ALL)\n")
2084      ("  (:FROM \"COM.INFORMATIMAGO.COMMON-LISP.STRING\"  :IMPORT :ALL)\n")
2085      ("  (:FROM \"COM.INFORMATIMAGO.COMMON-LISP.LIST\"    :IMPORT :ALL)\n")
2086      ("  (:EXPORT ))\n\n"))))
2087
2088
2089 (defun pjb-wrap-in-eval-when (start end)
2090   (interactive "r")
2091   (let ((b (make-marker))
2092           (e (make-marker)))
2093       (set-marker b  (min start end))
2094       (set-marker e  (max start end))
2095       (goto-char b)
2096       (insert "(eval-when (:compile-toplevel :load-toplevel :execute)\n")
2097       (goto-char e)
2098       (insert ");;eval-when")
2099       (indent-region b (1+ e))
2100       (goto-char b)))
2101
2102 ;; ------------------------------------------------------------------------
2103 ;; pjb-add-header
2104 ;; ------------------------------------------------------------------------
2105 ;; Insert a fresh header at the beginning of the buffer.
2106 ;;
2107
2108 (defun pjb-fill-a-line (format length)
2109   (do* ((stars (make-string length ?*) (subseq stars 1))
2110         (line  (format format stars) (format format stars)))
2111        ((<= (length line) length) line)))
2112
2113
2114 (defparameter pjb-sources-licenses 
2115   '(("GPL2"           
2116      t
2117      "This program is free software; you can redistribute it and/or"
2118      "modify it under the terms of the GNU General Public License"
2119      "as published by the Free Software Foundation; either version"
2120      "2 of the License, or (at your option) any later version."
2121      ""
2122      "This program is distributed in the hope that it will be"
2123      "useful, but WITHOUT ANY WARRANTY; without even the implied"
2124      "warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR"
2125      "PURPOSE.  See the GNU General Public License for more details."
2126      ""
2127      "You should have received a copy of the GNU General Public"
2128      "License along with this program; if not, write to the Free"
2129      "Software Foundation, Inc., 59 Temple Place, Suite 330,"
2130      "Boston, MA 02111-1307 USA")
2131
2132     ("LGPL2"          
2133      t
2134      "This library is free software; you can redistribute it and/or"
2135      "modify it under the terms of the GNU Lesser General Public"
2136      "License as published by the Free Software Foundation; either"
2137      "version 2 of the License, or (at your option) any later"
2138      "version."
2139      ""
2140      "This library is distributed in the hope that it will be"
2141      "useful, but WITHOUT ANY WARRANTY; without even the implied"
2142      "warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR"
2143      "PURPOSE.  See the GNU Lesser General Public License for more"
2144      "details."
2145      ""
2146      "You should have received a copy of the GNU Lesser General"
2147      "Public License along with this library; if not, write to the"
2148      "Free Software Foundation, Inc., 59 Temple Place, Suite 330,"
2149      "Boston, MA 02111-1307 USA")
2150
2151     ("LLGPL"          
2152      t
2153
2154      "This library is licenced under the Lisp Lesser General Public"
2155      "License."
2156      ""
2157      "This library is free software; you can redistribute it and/or"
2158      "modify it under the terms of the GNU Lesser General Public"
2159      "License as published by the Free Software Foundation; either"
2160      "version 2 of the License, or (at your option) any later"
2161      "version."
2162      ""
2163      "This library is distributed in the hope that it will be"
2164      "useful, but WITHOUT ANY WARRANTY; without even the implied"
2165      "warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR"
2166      "PURPOSE.  See the GNU Lesser General Public License for more"
2167      "details."
2168      ""
2169      "You should have received a copy of the GNU Lesser General"
2170      "Public License along with this library; if not, write to the"
2171      "Free Software Foundation, Inc., 59 Temple Place, Suite 330,"
2172      "Boston, MA 02111-1307 USA")
2173
2174     ("GPL3"
2175      t
2176      "This program is free software: you can redistribute it and/or modify"
2177     "it under the terms of the GNU General Public License as published by"
2178     "the Free Software Foundation, either version 3 of the License, or"
2179     "(at your option) any later version."
2180      ""
2181     "This program is distributed in the hope that it will be useful,"
2182     "but WITHOUT ANY WARRANTY; without even the implied warranty of"
2183     "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"
2184     "GNU General Public License for more details."
2185      ""
2186     "You should have received a copy of the GNU General Public License"
2187     "along with this program.  If not, see <http://www.gnu.org/licenses/>.")
2188
2189     ("GPL3-fr"
2190      t
2191      "Ce programme est un logiciel libre ; vous pouvez le redistribuer ou le"
2192      "modifier suivant les termes de la \93GNU General Public License\94 telle que"
2193      "publiée par la Free Software Foundation : soit la version 3 de cette"
2194      "licence, soit (à votre gré) toute version ultérieure."
2195      ""
2196      "Ce programme est distribué dans l\92espoir qu\92il vous sera utile, mais SANS"
2197      "AUCUNE GARANTIE : sans même la garantie implicite de COMMERCIALISABILITÉ"
2198      "ni d\92ADÉQUATION À UN OBJECTIF PARTICULIER. Consultez la Licence Générale"
2199      "Publique GNU pour plus de détails."
2200      ""
2201      "Vous devriez avoir reçu une copie de la Licence Générale Publique GNU avec"
2202      "ce programme ; si ce n\92est pas le cas, consultez :"
2203      "<http://www.gnu.org/licenses/>.")
2204
2205     ("AGPL3"
2206      t
2207      "This program is free software: you can redistribute it and/or modify"
2208      "it under the terms of the GNU Affero General Public License as published by"
2209      "the Free Software Foundation, either version 3 of the License, or"
2210      "(at your option) any later version."
2211      ""
2212      "This program is distributed in the hope that it will be useful,"
2213      "but WITHOUT ANY WARRANTY; without even the implied warranty of"
2214      "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"
2215      "GNU Affero General Public License for more details."
2216      ""
2217      "You should have received a copy of the GNU Affero General Public License"
2218      "along with this program.  If not, see <http://www.gnu.org/licenses/>.")
2219
2220     ("LGPL3"
2221      t
2222
2223      "This library is free software; you can redistribute it and/or"
2224      "modify it under the terms of the GNU Lesser General Public"
2225      "License as published by the Free Software Foundation; either"
2226      "version 3 of the License, or (at your option) any later"
2227      "version."
2228      ""
2229      "This library is distributed in the hope that it will be"
2230      "useful, but WITHOUT ANY WARRANTY; without even the implied"
2231      "warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR"
2232      "PURPOSE.  See the GNU Lesser General Public License for more"
2233      "details."
2234      ""
2235      "You should have received a copy of the  GNU Lesser General"
2236      "Public License along with this library."
2237      "If not, see <http://www.gnu.org/licenses/>.")
2238
2239     ("BSD-2"
2240      t
2241      "All rights reserved."
2242      ""
2243      "Redistribution and use in source and binary forms, with or without"
2244      "modification, are permitted provided that the following conditions are"
2245      "met: "
2246      ""
2247      "1. Redistributions of source code must retain the above copyright"
2248      "   notice, this list of conditions and the following disclaimer. "
2249      ""
2250      "2. Redistributions in binary form must reproduce the above copyright"
2251      "   notice, this list of conditions and the following disclaimer in the"
2252      "   documentation and/or other materials provided with the"
2253      "   distribution. "
2254      ""
2255      "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS"
2256      "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT"
2257      "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR"
2258      "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT"
2259      "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,"
2260      "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT"
2261      "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,"
2262      "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY"
2263      "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT"
2264      "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE"
2265      "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."
2266      ""
2267      "The views and conclusions contained in the software and documentation"
2268      "are those of the authors and should not be interpreted as representing"
2269      "official policies,  either expressed or implied, of the FreeBSD"
2270      "Project.")
2271     
2272     ("BSD-3"
2273      t
2274      "Redistribution and use in source and binary forms, with or"
2275      "without modification, are permitted provided that the following"
2276      "conditions are met:"
2277      ""
2278      "   1. Redistributions of source code must retain the above"
2279      "      copyright notice, this list of conditions and the"
2280      "      following disclaimer."
2281      ""
2282      "   2. Redistributions in binary form must reproduce the above"
2283      "      copyright notice, this list of conditions and the"
2284      "      following disclaimer in the documentation and/or other"
2285      "      materials provided with the distribution."
2286      ""
2287      "   3. The name of the author may not be used to endorse or"
2288      "      promote products derived from this software without"
2289      "      specific prior written permission."
2290      ""
2291      "THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY"
2292      "EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,"
2293      "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A"
2294      "PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR"
2295      "BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,"
2296      "EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED"
2297      "TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,"
2298      "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND"
2299      "ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT"
2300      "LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING"
2301      "IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF"
2302      "THE POSSIBILITY OF SUCH DAMAGE.")
2303
2304     ("Public Domain" 
2305      nil
2306      "This software is in Public Domain."
2307      "You're free to do with it as you please.")
2308
2309     ("Reserved"      
2310      t
2311      "All Rights Reserved."
2312      ""
2313      "This program may not be included in any commercial product"
2314      "without the author written permission. It may be used freely"
2315      "for any non-commercial purpose, provided that this header is"
2316      "always included.")
2317
2318     ("Proprietary"      
2319      t
2320      "All Rights Reserved."
2321      ""
2322      "This program and its documentation constitute intellectual property "
2323      "of Pascal J. Bourguignon and is protected by the copyright laws of "
2324      "the European Union and other countries.")
2325
2326     ("medicalis"
2327      t
2328      "Copyright 2008 Medical Information Systems. "
2329      ""
2330      "All Rights Reserved.")
2331     )
2332   "An a-list of (license name,  copyright-flag copyright-line...).
2333    When the copyright-flag is not nil, a copyright line is displayed.
2334    URL: http://www.gnu.org/licenses/license-list.html")
2335
2336
2337 (defun pjb-insert-license (license lic-data formated-copyright-lines
2338                            title-format comment-format)
2339   "PRIVATE"
2340   (insert (format title-format "LEGAL"))
2341   (insert "\n")
2342   (insert (format comment-format license))
2343   (insert "\n")
2344   (insert (format comment-format ""))
2345   (insert "\n")
2346   (when (pop lic-data)
2347     (dolist (line formated-copyright-lines) 
2348       (insert line)
2349       (insert "\n"))
2350     (insert (format comment-format ""))
2351     (insert "\n")
2352     )
2353   (do ((line (pop lic-data) (pop lic-data)))
2354       ((null line))
2355     (insert (format comment-format line))
2356     (insert "\n")))
2357
2358
2359 (defun pjb-add-header (license &optional system user-interface owner start-year end-year
2360                        modification description)
2361   "
2362 DO:               Inserts a header at the beginning of the file with
2363                   various  informations.
2364 `license'         a string naming one license in `pjb-sources-licenses'.
2365 `system'          a string naming a system (default: \"POSIX\").
2366 `user-interface'  a string naming a user interface (default: \"NONE\").
2367 `author'          a string naming the copyright owner (default: the author).
2368 `start-year'      the starting year of the copyright (default: the current year).
2369 `end-year'        the starting year of the copyright (default: the current year).
2370 `modification'    the modification comment (default: empty, the programmer can edit it later).
2371 `description'     the description of the file (default: \"XXX\", the programmer can edit it later).
2372 "
2373   (interactive
2374    (list (completing-read "License: " pjb-sources-licenses
2375                           nil t nil nil "GPL")))
2376   (goto-char (point-min))
2377   (let* ((data           (header-comment-description-for-mode major-mode))
2378          (first-format   (hcd-header-first-format data))
2379          (last-format    (hcd-header-last-format data))
2380          (title-format   (hcd-header-title-format data))
2381          (comment-format (hcd-header-comment-format data))
2382          (file-name      (basename (or (buffer-file-name (current-buffer))
2383                                        "Untitled")))
2384          (language       (subseq (symbol-name major-mode) 
2385                                  0 (search "-mode" (symbol-name major-mode))))
2386          (author-abrev   *pjb-sources-initials*)
2387          (author         (or add-log-full-name (user-full-name)))
2388          (owner          (or owner author))
2389          (email          user-mail-address)
2390          (year           (third (calendar-current-date)))
2391          (start-year     (or start-year year))
2392          (end-year       (or end-year   year))
2393          (line-length    78)
2394          (lic-data       (cdr (assoc license pjb-sources-licenses)))
2395          (system         (or system "POSIX"))
2396          (user-interface (or user-interface "NONE"))
2397          (modification   (or modification ""))
2398          (description    (or description "XXX")))
2399     (unless data
2400       (error "Don't know how to handle this major mode %S." major-mode))
2401     ;; (setq license (completing-read "License: " pjb-sources-licenses
2402     ;;                                nil t nil nil "GPL"))
2403     (cond
2404       ((eq major-mode 'emacs-lisp-mode)
2405        (setq language "emacs lisp"))
2406       ((eq major-mode 'lisp-mode)
2407        (setq language "Common-Lisp")
2408        (setq system   "Common-Lisp")))
2409     (save-excursion
2410       (save-restriction
2411         (widen)
2412         (goto-char (point-min))
2413         (insert (format title-format (format " -*- mode:%s;coding:utf-8 -*-"
2414                                              (mode-name major-mode))))
2415         (insert "\n")
2416         (insert (pjb-fill-a-line first-format line-length))
2417         (insert "\n")
2418         (insert (format title-format (format "%-20s%s" "FILE:" file-name)))
2419         (insert "\n")
2420         (insert (format title-format (format "%-20s%s" "LANGUAGE:" language)))
2421         (insert "\n")
2422         (insert (format title-format (format "%-20s%s" "SYSTEM:" system)))
2423         (insert "\n")
2424         (insert (format title-format (format "%-20s%s" "USER-INTERFACE:" 
2425                                              user-interface)))
2426         (insert "\n")
2427         (insert (format title-format "DESCRIPTION"))
2428         (insert "\n")
2429         (insert (format comment-format ""))
2430         (insert "\n")
2431         (insert (format comment-format description))
2432         (insert "\n")
2433         (insert (format comment-format ""))
2434         (insert "\n")
2435         (insert (format title-format "AUTHORS"))
2436         (insert "\n")
2437         (insert (format comment-format (format "<%s> %s <%s>" 
2438                                          author-abrev author email)))
2439         (insert "\n")
2440         (insert (format title-format "MODIFICATIONS"))
2441         (insert "\n")
2442         (insert (format title-format "BUGS"))
2443         (insert "\n")
2444         (pjb-insert-license 
2445          license lic-data
2446          (list (pjb-format-copyright data owner start-year end-year))
2447          title-format comment-format)
2448         (insert (pjb-fill-a-line last-format line-length))
2449         (insert "\n")
2450         (insert (format comment-format ""))
2451         (insert "\n"))))
2452   (pjb-add-change-log-entry modification))
2453
2454
2455 ;; ------------------------------------------------------------------------
2456 ;; pjb-change-license
2457 ;; ------------------------------------------------------------------------
2458 ;; Change the license in the header.
2459 ;;
2460
2461
2462 (defun pjb-change-license (license)
2463   "
2464 DO:         Assuming there's already a header with a LEGAL section,
2465             change the license.
2466 "
2467   (interactive (list 
2468                 (completing-read "License: " pjb-sources-licenses
2469                                  nil t nil nil "GPL")))
2470   (let* ((data           (header-comment-description-for-mode major-mode))
2471          (first-format   (hcd-header-first-format data))
2472          (last-format    (hcd-header-last-format data))
2473          (title-format   (hcd-header-title-format data))
2474          (comment-format (hcd-header-comment-format data))
2475          (file-name      (basename (or (buffer-file-name (current-buffer))
2476                                        "Untitled")))
2477          (language       (subseq (symbol-name major-mode) 
2478                                  0 (search "-mode" (symbol-name major-mode))))
2479          (author-abrev   *pjb-sources-initials*)
2480          (author         (or add-log-full-name (user-full-name)))
2481          (email          user-mail-address)
2482          (year           (elt (MULTIPLE-VALUE-LIST (GET-DECODED-TIME)) 5))
2483          (line-length    78)
2484          lic-data
2485          start end
2486          (copyrights '())
2487          )
2488     (unless data
2489       (error "Don't know how to handle this major mode %S." major-mode))
2490     (setq lic-data (cdr (assoc license pjb-sources-licenses)))
2491     (save-excursion
2492       (save-restriction
2493         (widen)
2494         (goto-char (point-min))
2495         (if (re-search-forward 
2496              (format "^%s" (regexp-quote (format title-format "LEGAL")))
2497              nil t)
2498             (progn (beginning-of-line)  (setq start (point)))
2499             (error "Can't find a LEGAL section. Please use M-x pjb-add-header"))
2500         (if (re-search-forward 
2501              (format "^%s" 
2502                (format (regexp-quote last-format) 
2503                  (format "%s.*" 
2504                    (regexp-quote "*************"))))
2505              nil t)
2506             (progn (beginning-of-line) (setq end (point)))
2507             (error 
2508              "Can't find the end of the header. Please use M-x pjb-add-header"))
2509         (goto-char start)
2510         (setf copyrights  (let ((old-copyrights (pjb-extract-copyrights data)))
2511                             (if old-copyrights
2512                                 (mapcar  (lambda (old-copyright)
2513                                            (destructuring-bind (author year-0 year-1) old-copyright
2514                                              (pjb-format-copyright data author year-0 year-1)))
2515                                          old-copyrights)
2516                                 (list (pjb-format-copyright data author year year)))))
2517         (delete-region start end)
2518         (pjb-insert-license  license lic-data copyrights
2519                              title-format comment-format))))
2520   :changed)
2521
2522
2523 ;; ------------------------------------------------------------------------
2524 ;; pjb-update-eof
2525 ;; ------------------------------------------------------------------------
2526 ;; Inserts or update a comment at the end of the current source buffer
2527 ;; containing the name of the file, the author and the date.
2528 ;;
2529
2530
2531 ;;; (mapc (lambda (s) (printf "%s\n" s))
2532 ;;;       (sort
2533 ;;;        (let ((res '()))
2534 ;;;          (mapatoms (lambda (sym) 
2535 ;;;                      (when (and (fboundp sym)
2536 ;;;                                 (string-has-suffix 
2537 ;;;                                   (symbol-name sym) "-mode"))
2538 ;;;                        (push sym res))))
2539 ;;;          res)
2540 ;;;        (lambda (a b) (STRING<= (symbol-name a) (symbol-name b))))
2541 ;;;       )
2542
2543
2544
2545 ;;; (defun pjb-ue-file-kind (name)
2546 ;;;   "
2547 ;;; DO:     Determine the file kind based on matching patterns in 
2548 ;;;         pjb-ue-extensions. If this cannot be done, looks at the major-mode.
2549 ;;; "
2550 ;;;   (let ((e pjb-ue-extensions)
2551 ;;;         k l r)
2552 ;;;     (while e
2553 ;;;       (setq k (caar e)
2554 ;;;             l (cdar e)
2555 ;;;             e (cdr e))
2556 ;;;       (while l
2557 ;;;         ;; (message "Matching %s %S \n" (car l) name)
2558 ;;;         (if (string-match (car l) name)
2559 ;;;             (setq r k
2560 ;;;                   e nil
2561 ;;;                   l nil))
2562 ;;;         (setq l (cdr l))))
2563 ;;;     r));;pjb-ue-file-kind 
2564
2565
2566 (defvar *pjb-ue-silent* nil 
2567   "When true, no error is issued if the file kind can't be determined.")
2568
2569
2570 (defun pjb-ue-get-format-for-mode (mode)
2571   (let ((data (header-comment-description-for-mode mode)))
2572     (cond
2573       (data     (hcd-eof-format data))
2574       (*pjb-ue-silent*  "")
2575       (t        (error (format "Unknown mode."))))))
2576
2577
2578 (defun pjb-ue-make-eof-for-current-buffer (format-string)
2579   (let ((bn (basename (or (buffer-file-name (current-buffer)) "Untitled"))))
2580     (format format-string
2581       bn
2582       ""       ;; (format-time-string "%Y-%m-%d %H:%M:%S")
2583       ""       ;;(user-real-login-name)
2584       )))
2585
2586
2587 (defun pjb-ue-split-format-string (format-string)
2588   (let ((save-case-fold-search case-fold-search)
2589         (position 0)
2590         (index)
2591         (chunks nil)
2592         )
2593     (setq index (string-match "%[0-9-.]*[sdefgcS]" format-string position))
2594     (while index
2595       (push (substring format-string position index) chunks)
2596       (setq position (match-end 0))
2597       (setq index (string-match "%[0-9-.]*[sdefgcS]" format-string position))
2598       )
2599     (push (substring format-string position index) chunks)
2600     (nreverse chunks)))
2601
2602
2603 (defun pjb-ue-make-regexp-for-current-buffer (format-string)
2604   (concat "^"
2605           (unsplit-string 
2606            (mapcar 'regexp-quote 
2607                    (pjb-ue-split-format-string format-string)) ".*")
2608           "$"))
2609
2610
2611 ;; Don't test pjb-update-eof without an eof string in this file, 
2612 ;; since it contains matching format string much higher in the text...
2613
2614 (defun pjb-update-eof (&optional *pjb-ue-silent*)
2615   "
2616 DO:         Insert a comment at the end of the source file with 
2617             the name of the file, the author, and the date.
2618 silent:     When non-nil, don't issue any message whent the file type can't
2619             be determined.
2620 "
2621   (interactive "*")
2622   (save-excursion
2623     (goto-char (point-max))
2624     (let* ((format-string (pjb-ue-get-format-for-mode major-mode))
2625            (eof-string    (pjb-ue-make-eof-for-current-buffer format-string)) )
2626       (if (re-search-backward
2627            (pjb-ue-make-regexp-for-current-buffer format-string) nil t)
2628           (progn
2629             (delete-region (match-beginning 0) (match-end 0))
2630             (insert eof-string))
2631           (progn
2632             (goto-char (point-max))
2633             (insert (format "\n%s\n" eof-string)) )))))
2634
2635
2636 ;; ------------------------------------------------------------------------
2637
2638
2639
2640
2641 ;;; (when nil
2642 ;;;   (defun haha-bug! ()
2643 ;;;     (interactive)
2644 ;;;     (let ((test-buffer (get-buffer-create "*Exemple*")))
2645 ;;;       (switch-to-buffer test-buffer)
2646 ;;;       (erase-buffer)
2647 ;;;       ;; Setup of the test buffer
2648 ;;;       (insert "***************************************************************************\n")
2649 ;;;       (insert "                  A TITLE COMMENT                    \n")
2650 ;;;       (insert "****************************************************/\n")
2651 ;;;       (let ((i 0)) 
2652 ;;;         (while (< i 100)
2653 ;;;           (insert " a b c d e f g h i j k l m n o p q r s t u v w x y z \n")
2654 ;;;           (insert " A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \n")
2655 ;;;           (setq i (1+ i))
2656 ;;;           ))
2657 ;;;       (insert "/*** PATTTTTERN -- PATTTTTTERN -- PATTTTTTERN ***/\n")
2658 ;;;       (goto-char (point-min)) ;; does not matter where.
2659 ;;;       ;; Here we start the problematic procedure.
2660 ;;;       (save-excursion
2661 ;;;         (goto-char (point-max))
2662 ;;;         (if (re-search-backward "^/\\*\\*\\* .* -- .* -- .* \\*\\*\\*/$" nil t)
2663 ;;;             (replace-match "/*** REPLACE -- REPLACE -- REPLACE ***/" t t)
2664 ;;;           (goto-char (point-max))
2665 ;;;           (insert "/*** REPLACE -- REPLACE -- REPLACE ***/")))))
2666 ;;;   )
2667
2668     
2669     
2670
2671
2672 (defun pjb-grep-here (pattern)
2673   "Does an egrep  in the current directory just asking for a pattern."
2674   (interactive "segrep pattern: ")
2675   (if (null pattern)
2676       (error "Expecting a pattern to do the egrep."))
2677   (if (string-equal "" pattern)
2678       (error "The empty string matches everything. Are you happy?"))
2679   (grep (format "egrep -n -e '%s' `find . -type f -print` /dev/null" pattern)))
2680