Menu
▾
▴
[Maxima-commits] CVS: maxima/src cl-info.lisp, 1.33, 1.34 init-cl.lisp, 1.75, 1.76 macdes.lisp, 1.29, 1.30 maxima-package.lisp, 1.28, 1.29 mdebug.lisp, 1.27, 1.28
|
From: Robert D. <rob...@us...> - 2006-11-29 05:35:16
|
Update of /cvsroot/maxima/maxima/src In directory sc8-pr-cvs7.sourceforge.net:/tmp/cvs-serv24093/src Modified Files: cl-info.lisp init-cl.lisp macdes.lisp maxima-package.lisp mdebug.lisp Log Message: Merge revision of describe into CVS main branch. Merge was accomplished by cvs update -j describe-revision-base -j describe-revision-branch followed by manual adjustment of doc/info/Makefile.am and doc/info/*/Makefile.am (only minor adjustments were needed for each Makefile.am). With result of merge, make, make check, make install all succeed, and describe functions work as expected for en, es_ES, es_ES.UTF-8, pt_BR, and pt_BR.UTF-8. The one remaining wart is that a warning message is printed the first time some documentation is accessed. This is from the autoload mechanism. We should figure out a way to quiet the message (by avoiding autoload or otherwise). Index: cl-info.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/cl-info.lisp,v retrieving revision 1.33 retrieving revision 1.34 diff -u -d -r1.33 -r1.34 --- cl-info.lisp 27 Jul 2006 05:37:45 -0000 1.33 +++ cl-info.lisp 29 Nov 2006 05:35:03 -0000 1.34 @@ -1,724 +1,7 @@ -;;; This is port of GCL's info.lsp to Clisp. This should basically be -;;; portable Common Lisp, but I haven't tested it with anything else. - -;; CAUTION: This file contains non-printing characters! -;; -;; The regexp syntax used in this file is the syntax used by nregex. -;; -;; In summary: -;; -;; . (a period) matches any single character -;; [] character set -;; ^ beginning of line -;; $ end of line -;; ( ) grouping -;; * zero or more -;; ? zero or one matches -;; + one or more -;; - - (in-package :cl-info) -(defvar *index-name* "index") -(defvar *extra-chars* "") - -(defvar *match-data*) -(defvar *case-fold-search* nil) - -(defun match-start (n) - (first (aref *match-data* n))) -(defun match-beginning (n) - (match-start n)) -(defun match-end (n) - (second (aref *match-data* n))) -(defun get-match (s n) - (subseq s (match-start n) (match-end n))) - - -;; Compile the regex pattern in PAT for use by the string matcher. We -;; precompile three regex's that are used for all queries. If there -;; were any more, I would have put them in a hash table -;; -- jfa 07/24/04 -(let* ((string1 (format nil "Node: ([^~a]*index[^~a]*)~a" - (code-char 127) (code-char 127) (code-char 127))) - (string2 (format nil "Node: Function and Variable Index~a([0-9]+)" - (code-char 127))) - (string3 (format nil "~a[~a~a][^~a]*Node:[~a~a]+Function and Variable Index[,~a~a][^~a]*~a" - (code-char 31) (code-char 10) (code-char 12) - (code-char 10) (code-char 32) (code-char 9) - (code-char 9) (code-char 10) (code-char 10) - (code-char 10))) - (precomp-nil-string1 - #-gcl (compile nil (regex-compile string1 :case-sensitive nil)) - #+gcl (regex-compile string1 :case-sensitive nil)) - (precomp-t-string2 - #-gcl (compile nil (regex-compile string2 :case-sensitive nil)) - #+gcl (regex-compile string2 :case-sensitive nil)) - (precomp-t-string3 - #-gcl (compile nil (regex-compile string3 :case-sensitive nil)) - #+gcl (regex-compile string3 :case-sensitive nil))) - - (defun compile-regex (pat &key (case-sensitive t)) - (cond - ((and (equal case-sensitive nil) - (string= pat string1)) - precomp-nil-string1) - ((and (equal case-sensitive t) - (string= pat string2)) - precomp-t-string2) - ((and (equal case-sensitive t) - (string= pat string3)) - precomp-t-string3) - (t - (let ((*compile-print* nil) - (*compile-verbose* nil) - #+(or cmu scl) - (ext:*compile-progress* nil) - #+sbcl - (sb-ext:*compile-progress* nil) - #+gcl - (compiler:*compile-verbose* nil) - ) - #-gcl (compile nil (regex-compile pat :case-sensitive case-sensitive)) - #+gcl (regex-compile pat :case-sensitive case-sensitive))))) - ) -;; Search the string STRING for the pattern PAT. Only the part of the -;; string bounded by START and END are searched. PAT may either be a -;; string or a compiled regex (which is a function). -;; -;; If a match is not found, -1 is returned. Otherwise, the index of -;; the start of the match is returned. *match-data* contains -;; information about the matches for any groups in the pattern. -(defun string-match (pat string &optional (start 0) (end (length string))) - (when (stringp pat) - (setf pat (compile-regex pat :case-sensitive (not *case-fold-search*)))) - (if (funcall pat string :start start :end end) - (progn - (setf *match-data* (make-array *regex-groupings*)) - (dotimes (k *regex-groupings*) - (setf (aref *match-data* k) (aref *regex-groups* k))) - (match-start 0)) - -1)) - -(eval-when (compile load eval) - #-allegro - (defmacro while (test &body body) - `(loop while ,test do ,@ body)) - #+nil - (defmacro f (op x y) - `(,op (the fixnum ,x) (the fixnum ,y)))) - -;; #u"" is a C-style string where \n, \t, and \r are converted just as -;; in C. -(eval-when (compile eval load) - (defun sharp-u-reader (stream subchar arg) - (declare (ignore subchar arg)) - (let ((tem (make-array 10 :element-type 'character - :fill-pointer 0 :adjustable t))) - (unless (eql (read-char stream) #\") - (error "sharp-u-reader reader needs a \"right after it")) - (loop - (let ((ch (read-char stream))) - (cond ((eql ch #\") (return tem)) - ((eql ch #\\) - (setq ch (read-char stream)) - (setq ch (or (cdr (assoc ch '((#\n . #\newline) - (#\t . #\tab) - (#\r . #\return)))) - ch)))) - (vector-push-extend ch tem))) - (coerce tem '(simple-array character (*))))) - - (set-dispatch-macro-character #\# #\u 'sharp-u-reader) - ) -;; match unbalanced " above which confuse some editors - -(defvar *info-data* nil) -(defvar *current-info-data* nil) -(defvar *info-paths* - '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/" - "/usr/local/gnu/info/" "/usr/share/info/" )) - - -;; Read the contents of a file FILE starting at position START into a -;; string. -(defun file-to-string (file &optional (start 0)) - (with-open-file (st file) - (let ((len (file-length st))) - (unless (<= 0 start len) - (error "illegal file start ~a" start)) - #-gcl - (let ((tem (make-array (- len start) - :element-type 'character))) - (when (> start 0) - (file-position st start)) - (read-sequence tem st :start 0 :end (length tem)) - tem) - #+gcl - (let ((tem (make-array (- len start) - :element-type 'string-char))) - (if (> start 0) (file-position st start)) - (si::fread tem 0 (length tem) st) tem) - ))) - -(defun atoi (string start) - (parse-integer string :start start :junk-allowed t)) - -;; FILE is the main (first) info file. Search for the Indirect nodes -;; and the tag table which exists if the info files are split into -;; several files. -;; -;; Return a list of the tag table text itself and an alist of the -;; starting index for each file and the name of the corresponding -;; file. -(let ((pat-indirect-start (compile-regex #u" [ \n]+Indirect:" - :case-sensitive t)) - (pat-end-ind (compile-regex #u" " - :case-sensitive t)) - (pat-indirect (compile-regex #u"\n([^\n]+): ([0-9]+)" - :case-sensitive t)) - (pat-tag-table (compile-regex #u" [\n ]+Tag Table:" - :case-sensitive t)) - ) - (defun info-get-tags (file) - (let ((lim 0) - (*case-fold-search* t) - *match-data* tags files) - (declare (fixnum lim)) - (let ((s (file-to-string file)) - (i 0)) - (declare (fixnum i) - (string s)) - ;;(format t "match = ~a~%" (string-match #u" [ \n]+Indirect:" s 0)) - (when (>= (string-match pat-indirect-start s 0) 0) - ;; The file has multiple parts, so save the filename and the - ;; offset of each part. - (setq i (match-end 0)) - ;;(format t "looking for end of Indirect, from ~a~%" i) - (setq lim (string-match pat-end-ind s i)) - ;;(format t "found Indirect at ~a. limit = ~a~%" i lim) - (while (>= (string-match pat-indirect s i lim) - 0) - ;;(format t "found entry at ~a.~%" (match-start 0)) - (setq i (match-end 0)) - (setq files - (cons (cons - (atoi s (match-beginning 2)) - (get-match s 1) - ) - files)))) - ;;(format t "looking for tag table~%") - (when (>= (string-match pat-tag-table s i) 0) - (setq i (match-end 0)) - ;;(format t "found tag table: ~a ~a~%" (match-start 0) i) - (when (>= (string-match pat-end-ind s i) 0) - ;;(format t "found end at ~a ~a~%" i (match-start 0)) - (setq tags (subseq s i (match-end 0))))) - (if files - (or tags (info-error "need tags if have multiple files"))) - (list* tags (nreverse files))))) - ) - -;; Quote the given string, protecting any special regexp characters so -;; that they stand for themselves. -(defun re-quote-string (x) - (declare (string x)) - (let ((i 0) - (len (length x)) - ch - (extra 0)) - (declare (fixnum i len extra)) - (let (tem) - (tagbody - AGAIN - (while (< i len) - (setq ch (aref x i)) - ;; (cond ((position ch "\\()[]+.*|^$?") - (when (position ch "\\()[].*|^$") - (if tem - (vector-push-extend #\\ tem) - (incf extra))) - (when tem - (vector-push-extend ch tem)) - (setq i (+ i 1))) - (cond (tem ) - ((> extra 0) - (setq tem - (make-array (+ (length x) extra) - :element-type 'character :fill-pointer 0)) - (setq i 0) - (go AGAIN)) - (t (setq tem x))) - ) - tem))) - -(defun string-concatenate (&rest strings) - (apply #'concatenate 'string strings)) - -(defun get-nodes (pat node-string) - (let ((i 0) - (*case-fold-search* t) - (ans '()) - (*match-data* nil)) - (declare (fixnum i)) - (when node-string - (let ((compiled-pat - (compile-regex - (string-concatenate "Node: ([^]*" - (re-quote-string pat) - "[^]*)") - :case-sensitive (not *case-fold-search*)))) - (while (>= (string-match compiled-pat node-string i) 0) - (setq i (match-end 0)) - (setq ans (cons (get-match node-string 1) - ans))) - (nreverse ans))))) - -(defun get-index-node () - (or (third *current-info-data*) - (let* (s - (node-string (car (nth 1 *current-info-data*))) - (node - (and node-string (car (if (equal *index-name* "index") - (get-nodes *index-name* node-string) - (or (get-nodes *index-name* node-string) - (get-nodes "index" node-string))))))) - (when node - (setq s (show-info node nil)) - (setf (third *current-info-data*) s))))) - -;; Most of the cost of retrieving documentation is here. This should -;; be fast. -(defun nodes-from-index (pat) - (let ((i 0) - ans - (*case-fold-search* t) - *match-data* - (index-string (get-index-node))) - (when index-string - (let ((compiled-pat - (compile-regex - (string-concatenate #u"\n\\* ([^:\n]*" - (re-quote-string pat) - #u"[^:\n]*):[ \t]+([^\t\n,.]+)") - :case-sensitive (not *case-fold-search*)))) - (while (>= (string-match compiled-pat index-string i) 0) - (setq i (match-end 0)) - (push (cons (get-match index-string 1) (get-match index-string 2)) - ans)) - (nreverse ans))))) - -(defun get-node-index (pat node-string) - (let ((node pat) - *match-data*) - (cond ((null node-string) 0) - (t - (setq pat - (compile-regex - (string-concatenate "Node: " - (re-quote-string pat) - "([0-9]+)") - :case-sensitive (not *case-fold-search*))) - (cond ((>= (string-match pat node-string) 0) - (atoi node-string (match-beginning 1))) - (t - (info-error "can't find node ~s" node) 0)))))) - -(defun all-matches (pat st) - (let ((start 0) - *match-data*) - (declare (fixnum start)) - (loop while (>= (setq start (string-match pat st start)) 0) - collect (list start (setq start (match-end 0)))))) - - - -(defmacro node (prop x) - `(nth ,(position prop '(string begin end header name - info-subfile - file tags)) ,x)) - -(defun node-offset (node) - (+ (car (node info-subfile node)) (node begin node))) - -(defun file-search (name &optional (dirs *info-paths*) extensions (fail-p t)) - "search for the first occurrence of a file in the directory list dirs -that matches the name name with extention ext" - (dolist (dir dirs) - (let (base-name base-name-lang) - (setq base-name (make-pathname :device (pathname-device dir) - :directory (pathname-directory dir))) - (when *lang-subdir* - (setq base-name-lang (make-pathname :device (pathname-device dir) - :directory (append (pathname-directory dir) - `(,*lang-subdir*)) ))) - (dolist (type extensions) - (let (pathname) - (when *lang-subdir* - (setq pathname (make-pathname :name name - :type (if (equalp type "") - nil - type) - :defaults base-name-lang)) - (when (probe-file pathname) - (return-from file-search pathname))) - (setq pathname (make-pathname :name name - :type (if (equalp type "") - nil - type) - :defaults base-name)) - (when (probe-file pathname) - (return-from file-search pathname)))))) - ;; We couldn't find the file - (when fail-p - (error "lookup failed in directores: ~s for name ~s with extensions ~s" - dirs name extensions)) - nil) - -(defvar *old-lib-directory* nil) - -(defun setup-info (name) - (let (tem file) - (when (equal name "DIR") - (setq name "dir")) - (setq file (file-search name *info-paths* '("" "info") nil)) - (cond (file - (let* ((na (namestring (truename file)))) - (cond ((setq tem (assoc na *info-data* :test 'equal)) - (setq *current-info-data* tem)) - (t - (setq *current-info-data* - (list na (info-get-tags na) nil)) - (setq *info-data* (cons *current-info-data* *info-data*)))))) - (t (format t "setup-info: ~S not found in ~S~%" name *info-paths*))) - nil)) - -(defun get-info-choices (pat type) - (if (eql type 'index) - (nodes-from-index pat ) - (get-nodes pat (car (nth 1 *current-info-data*))))) - -(defun add-file (v file &aux (lis v)) - (while lis - (setf (car lis) (list (car lis) file)) - (setq lis (cdr lis))) - v) - -(defun info-error (&rest l) - (apply #'error l)) - -;; Cache the last file read to speed up lookup since it may be -;; gzipped. However, we don't support gzipped info files at this time. -(defvar *last-info-file* nil) - -(defun info-get-file (pathname) - (setq pathname - (if (stringp (car *current-info-data*)) - (merge-pathnames pathname - (car *current-info-data*)) - pathname)) - (cdr - (cond ((equal (car *last-info-file*) pathname) - *last-info-file*) - (t (setq *last-info-file* - (cons pathname (file-to-string pathname))))))) - -(defun info-subfile (n) - ;; "for an index n return (start . file) for info subfile - ;; which contains N. A second value bounding the limit if known - ;; is returned. At last file this limit is nil." - (let ((lis (cdr (nth 1 *current-info-data*))) - ans lim) - (when (and lis (>= n 0)) - (dolist (v lis) - (cond ((> (car v) n ) - (setq lim (car v)) - (return nil))) - (setq ans v) - )) - (values (or ans (cons 0 (car *current-info-data*))) lim))) - -;;used by search -(let ((pat-marker (compile-regex #u"^_" :case-sensitive t)) - (pat-node (compile-regex - #u" [\n ][^\n]*Node:[ \t]+([^\n\t,]+)[\n\t,][^\n]*\n" - :case-sensitive t)) - (pat-marker2 (compile-regex "[ ]"))) - (defun info-node-from-position (n &aux (i 0)) - (let* ((info-subfile (info-subfile n)) - (s (info-get-file (cdr info-subfile))) - (end (- n (car info-subfile)))) - (while (>= (string-match pat-marker s i end) 0) - (setq i (match-end 0))) - (setq i (- i 1)) - (if (>= (string-match pat-node s i) 0) - (let* ((i (match-beginning 0)) - (beg (match-end 0)) - (name (get-match s 1)) - (end (if (>= (string-match pat-marker2 s beg) 0) - (match-beginning 0) - (length s))) - (node (list* s beg end i name info-subfile - *current-info-data*))) - node)))) - ) - -;; SHOW-INFO is the main routine to find the desired documentation. - -(let ((pat-file-node (compile-regex "^(\\([^(]+\\))([^)]*)")) - ;; This is the pattern for the beginning of a node - (pat-markers (compile-regex "[ ]")) - ;; This is the pattern for a subnode. That is the documention - ;; for some function or variable. - (pat-subnode (compile-regex #u"\n -+ [a-zA-Z]")) - ;; This pattern is used to match where the documentation of a - ;; subnode starts. - (doc-start (compile-regex #u"\n "))) - (defun show-info (name &optional position-pattern) - (let ((*match-data* nil) - (initial-offset 0) - (subnode -1) - info-subfile file) - (declare (fixnum subnode initial-offset)) - (when (and (consp name) (consp (cdr name))) - (setq file (cadr name) - name (car name))) - (when (consp name) - (setq position-pattern (car name) name (cdr name))) - (unless (stringp name) - (info-error "bad arg")) - (when (>= (string-match pat-file-node name) 0) - ;; (file)node - (setq file (get-match name 1)) - (setq name (get-match name 2)) - (when (equal name "") - (setq name "Top"))) - (when file - (setup-info file)) - (let ((indirect-index (get-node-index name - (car (nth 1 *current-info-data*))))) - (when (null indirect-index) - (format t "~%Sorry, Can't find node ~a" name) - (return-from show-info nil)) - - (setq info-subfile (info-subfile indirect-index)) - - (let* ((s (info-get-file (cdr info-subfile))) - (start (- indirect-index (car info-subfile)))) - (unless (>= (string-match - (string-concatenate - #u" [\n ][^\n]*Node:[ \t]+" - (re-quote-string name) - #u"[,\t\n][^\n]*\n") - (or s "") start) - 0) - (info-error "Can't find node ~a?" name)) - (let* ((beg (match-end 0)) - (end (if (>= (string-match pat-markers s beg) 0) - (match-beginning 0) - (length s)))) - - (when position-pattern - (setq position-pattern (re-quote-string position-pattern)) - - #+nil - (format t "position-pattern = ~S~%" position-pattern) - ;; The position pattern might look like "psi <n>", where - ;; n is some number. If so, we need to remove the <n> - ;; part because it doesn't actually show up in the info - ;; file. - (when (>= (string-match "(.*) +<[0-9]+>" position-pattern) 0) - (setq position-pattern - (subseq position-pattern - 0 - (match-end 1))) - #+nil - (progn - (format t "beginning, end = ~A ~A~%" (match-beginning 1) (match-end 1)) - (format t "position-pattern = ~S~%" position-pattern)) - ) - - #+nil - (progn - (format t "subnode pattern = ~A~%" - (string-concatenate - (format nil #u"\n -+ [A-Za-z~a ]+: " *extra-chars*) - position-pattern - #u"[ \n]" - )) - (format t "pattern at ~A~%" - (string-match - (string-concatenate - (format nil #u"\n -+ [A-Za-z~a ]+: " *extra-chars*) - position-pattern - #u"[ \n]" - ) - s beg end)) - (format t "~S~%" (subseq s beg end))) - - ;; This looks for the desired pattern. A typical entry - ;; looks like - ;; - ;; " - Function: plot2d <random stuff>" - ;; - ;; So we look for the beginning of a line, the string " - - ;; ", followed by at least one letter or spaces and then a - ;; colon. After that is our desired pattern and a space - ;; or new line. - (let (*case-fold-search*) - (when (or (>= (setq subnode - (string-match - (string-concatenate - (format nil #u"\n -+ [A-Za-z~a ]+: " *extra-chars*) - position-pattern - #u"[ \n]" - ) - s beg end)) - 0) - (>= (string-match position-pattern s beg end) - 0)) - (setq initial-offset - (- (match-beginning 0) beg))))) - #+nil - (progn - (format t "initial-offset = ~A~%" initial-offset) - (format t "subnode = ~A~%" subnode) - (format t "end = ~A~%" end)) - - ;; We now need to find the end of the documentation. - ;; Usually, the end is where the next node begins. However, - ;; sometimes several nodes are given in a row without - ;; separate documentation for each, whereby the same - ;; documentation is used to describe these nodes. - ;; - ;; So, what we do is look for the beginning of the - ;; documentation, which starts on a new line with at least 4 - ;; spaces. Then we look for the next node. The is where - ;; our documentation ends. If there is no next node, the - ;; end is where the marker is. - (let ((e (if (minusp subnode) - end - (let* ((start-doc - (string-match doc-start s - (+ beg 1 initial-offset) end))) - ;;(format t "start-doc = ~A~%" start-doc) - (cond ((>= (string-match (format nil #u"\n -+ [a-zA-Z~a]" *extra-chars*) - s - (if (>= start-doc 0) - start-doc - (+ beg 1 initial-offset)) - end) - 0) - ;;(format t "end at ~A~%" (match-beginning 0)) - (match-beginning 0)) - (t - ;; No next node, so the end point we - ;; found is really the end point we - ;; want. - end)))))) - - (subseq s (+ initial-offset beg) e))))))) - ) - -(defvar *default-info-files* '("maxima.info")) -(defvar *lang-subdir* nil) - -(defun info-aux (x dirs) - (loop for v in dirs - do - (setup-info v) - append (add-file (get-info-choices x 'node) v) - append (add-file (get-info-choices x 'index) v))) - -(defun info-search (pattern &optional (start 0) end) - "search for PATTERN from START up to END where these are indices in -the general info file. The search goes over all files." - (let ((limit 0)) - (while start - (multiple-value-bind - (file lim) - (info-subfile start) - (setq limit lim) - (and end limit (< end limit) (setq limit end)) - - (let* ((s (info-get-file (cdr file))) - (beg (car file)) - (i (- start beg)) - (leng (length s))) - (when (>= (string-match pattern s i (if limit (- limit beg) leng)) 0) - (return-from info-search (+ beg (match-beginning 0))))) - (setq start lim))) - -1)) - -#+debug ; try searching -(defun try (pat &aux (tem 0) s ) - (while (>= tem 0) - (cond ((>= (setq tem (info-search pat tem)) 0) - (setq s (cdr *last-info-file*)) - (print (list - tem - (list-matches s 0 1 2) - (car *last-info-file*) - (subseq s - (max 0 (- (match-beginning 0) 50)) - (min (+ (match-end 0) 50) (length s))))) - (setq tem (+ tem (- (match-end 0) (match-beginning 0)))))))) - -(defun idescribe (name) - (let* ((items (info-aux name *default-info-files*))) - (dolist (v items) - (when (cond ((consp (car v)) - (equalp (caar v) name)) - (t (equalp (car v) name))) - (format t "~%From ~a:~%" v) - (princ (show-info v nil)))))) - -;; Main entry point. This looks up the desired entry and prompts the -;; user to select the desired entries when multiple matches are found. -(defun info (x &optional (dirs *default-info-files*) (info-paths *info-paths*) - &aux *current-info-data*) - (let (wanted - file - position-pattern - tem - (*info-paths* info-paths)) - (setf tem (info-aux x dirs)) - (when tem - (let ((nitems (length tem))) - (loop for i from 0 for name in tem with prev - do - (setq file nil - position-pattern nil) - (progn - ;; decode name - (when (and (consp name) (consp (cdr name))) - (setq file (cadr name) - name (car name))) - (when (consp name) - (setq position-pattern (car name) name (cdr name)))) - (when (> nitems 1) - (format t "~% ~d: ~@[~a :~]~@[(~a)~]~a." i - position-pattern - (if (eq file prev) nil (setq prev file)) name))) - (setq wanted - (if (> nitems 1) - (loop - for prompt-count from 0 - thereis (progn - (finish-output *debug-io*) - (print-prompt prompt-count) - (force-output) - (clear-input) - (select-info-items - (parse-user-choice nitems) tem))) - tem)) - (clear-input) - (finish-output *debug-io*) - (when (consp wanted) - (loop for item in wanted - do (princ (show-info item))))))) - (values)) +(defvar *info-section-hashtable* (make-hash-table :test 'equal)) +(defvar *info-deffn-defvr-hashtable* (make-hash-table :test 'equal)) (defvar *prompt-prefix* "") (defvar *prompt-suffix* "") @@ -764,39 +47,140 @@ (all items) (none 'none))) - #|| -;; idea make info_text window have previous,next,up bindings on keys -;; and on menu bar. Have it bring up apropos menu. allow selection -;; to say spawn another info_text window. The symbol that is the window -;; will carry on its plist the prev,next etc nodes, and the string-to-file -;; cache the last read file as well. Add look up in index file, so that can -;; search an indtqex as well. Could be an optional arg to show-node -;; +; ------------------------------------------------------------------ +; STUFF ABOVE SALVAGED FROM PREVIOUS INCARNATION OF SRC/CL-INFO.LISP +; STUFF BELOW IS NEW, BASED ON LOOKUP TABLE BUILT AHEAD OF TIME +; ------------------------------------------------------------------ +; ------------------ search help topics ------------------ +(defun info-exact (x) + (cause-maxima-index-to-load) + (let ((exact-matches (exact-topic-match x))) + (if (null exact-matches) + (progn + (format t " No exact match found for topic `~a'.~% Try `? ~a' (inexact match) instead.~%~%" x x) + nil) + (progn + (format t "~%") + (loop for item in exact-matches + do (format t "~A~%~%" (read-info-text item))) + (if (some-inexact x (inexact-topic-match x)) + (format t " There are also some inexact matches for `~a'.~% Try `? ~a' to see them.~%~%" x x)) + t)))) -(defun default-info-hotlist() - (namestring (merge-pathnames "hotlist" (user-homedir-pathname)))) +(defun some-inexact (x inexact-matches) + (some #'(lambda (y) (not (equal y x))) (mapcar #'car inexact-matches))) -(defun add-to-hotlist (node ) - (if (symbolp node) (setq node (get node 'node))) - (cond - (node - (with-open-file - (st (default-info-hotlist) - :direction :output - :if-exists :append - :if-does-not-exist :create) - (cond ((< (file-position st) 10) - (princ #u" \nFile:\thotlist\tNode: Top\n\n* Menu: Hot list of favorite info items.\n\n" st))) - (format st "* (~a)~a::~%" - (node file node)(node name node)))))) +(defun exact-topic-match (topic) + (setq topic (regex-sanitize topic)) + (setq topic (concatenate 'string "^" topic "$")) + (append + (find-regex-matches topic *info-section-hashtable*) + (find-regex-matches topic *info-deffn-defvr-hashtable*))) -(defun list-matches (s &rest l) - (loop for i in l - collect - (and (>= (match-beginning i) 0) - (get-match s i)))) -||# +(defun info (x) + (cause-maxima-index-to-load) + (let (wanted tem) + (setf tem (inexact-topic-match x)) + (when tem + (let ((nitems (length tem))) + + (loop for i from 0 for item in tem with prev do + (when (> nitems 1) + (let ((heading-title (nth 3 (cdr item)))) + (format t "~% ~d: ~a~@[ (~a)~]" + i + (car item) + heading-title)))) + + (setq wanted + (if (> nitems 1) + (loop + for prompt-count from 0 + thereis (progn + (finish-output *debug-io*) + (print-prompt prompt-count) + (force-output) + (clear-input) + (select-info-items + (parse-user-choice nitems) tem))) + tem)) + (clear-input) + (finish-output *debug-io*) + (when (consp wanted) + (format t "~%") + (loop for item in wanted + do (format t "~A~%~%" (read-info-text item)))))) + + (not (null tem)))) + +(defun inexact-topic-match (topic) + (setq topic (regex-sanitize topic)) + (append + (find-regex-matches topic *info-section-hashtable*) + (find-regex-matches topic *info-deffn-defvr-hashtable*))) + +(defun regex-sanitize (s) + "Precede any regex special characters with a backslash." + (let + ((L (coerce maxima-nregex::*regex-special-chars* 'list))) + + ; WORK AROUND NREGEX STRANGENESS: CARET (^) IS NOT ON LIST *REGEX-SPECIAL-CHARS* + ; INSTEAD OF CHANGING NREGEX (WITH POTENTIAL FOR INTRODUCING SUBTLE BUGS) + ; JUST APPEND CARET TO LIST HERE + (setq L (cons #\^ L)) + + (coerce (apply #'append + (mapcar #'(lambda (c) (if (maxima::memq c L) `(#\\ ,c) `(,c))) (coerce s 'list))) + 'string))) + +(defun find-regex-matches (regex-string hashtable) + (let* + ((regex (maxima-nregex::regex-compile regex-string :case-sensitive nil)) + (regex-fcn (coerce regex 'function)) + (regex-matches nil)) + (maphash + #'(lambda (key value) + (if (funcall regex-fcn key) + (setq regex-matches (cons `(,key . ,value) regex-matches)) + nil)) + hashtable) + (stable-sort regex-matches #'string-lessp :key #'car))) +(defun read-info-text (x) + (declare (special maxima::*maxima-infodir* maxima::*maxima-lang-subdir*)) + (let* + ((key (car x)) + (value (cdr x)) + (filename (car value)) + (byte-offset (cadr value)) + (byte-count (caddr value)) + (text (make-string byte-count)) + (subdir-bit + (if (null maxima::*maxima-lang-subdir*) "" + (concatenate 'string "/" maxima::*maxima-lang-subdir*))) + (path+filename (concatenate 'string maxima::*maxima-infodir* subdir-bit "/" filename))) + (with-open-file (in path+filename :direction :input) + (file-position in byte-offset) + #+gcl (gcl-read-sequence text in :start 0 :end byte-count) + #-gcl (read-sequence text in :start 0 :end byte-count)) + text)) + +#+gcl +(defun gcl-read-sequence (s in &key (start 0) (end nil)) + (dotimes (i (- end start)) + (setf (aref s i) (read-char in)))) + +; --------------- build help topic indices --------------- + +(defun load-info-hashtables () + (declare (special *info-section-pairs* *info-deffn-defvr-pairs*)) + ; (format t "HEY, I'M LOADING THE INFO HASHTABLES NOW~%") + (mapc + #'(lambda (x) (setf (gethash (car x) *info-section-hashtable*) (cdr x))) + *info-section-pairs*) + (mapc + #'(lambda (x) (setf (gethash (car x) *info-deffn-defvr-hashtable*) (cdr x))) + *info-deffn-defvr-pairs*)) Index: init-cl.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/init-cl.lisp,v retrieving revision 1.75 retrieving revision 1.76 diff -u -d -r1.75 -r1.76 --- init-cl.lisp 18 Nov 2006 23:19:09 -0000 1.75 +++ init-cl.lisp 29 Nov 2006 05:35:03 -0000 1.76 @@ -237,29 +237,12 @@ ((equal language "en") (setq *maxima-lang-subdir* nil)) ;; Latin-1 aka iso-8859-1 languages - ((zl-member language '("es" "pt")) + ((zl-member language '("es" "pt" "fr" "de" "it")) (if (zl-member codeset '("utf-8" "utf8")) (setq *maxima-lang-subdir* (concatenate 'string language ".utf8")) (setq *maxima-lang-subdir* language))) (t (setq *maxima-lang-subdir* nil))) - ;; Translation of the word "Index" to match node "Fuction and Variable Index" - (cond - ((equal language "es") - (setq cl-info::*index-name* (format nil "~andice" (code-char #xCD)))) - ((equal language "pt") - (setq cl-info::*index-name* (format nil "~andice" (code-char #xCD)))) - ) - ;; Additional language-dependent pattern to match nodes such as - ;; -- Function: foo (x) - ;; or - ;; -- Option variable: bar - (cond - ;; This pattern is suitable for all Latin-1 (aka ISO-8859-1) langages - ((zl-member language '("es" "pt")) - (setq cl-info::*extra-chars* (format nil "~a-~a" (code-char #xC0) (code-char #xFF)))) - ) - ))) - (setq cl-info::*lang-subdir* *maxima-lang-subdir*))) + ))))) (defun set-pathnames () (let ((maxima-prefix-env (maxima-getenv "MAXIMA_PREFIX")) @@ -397,19 +380,10 @@ (list '(mlist) (combine-path (list *maxima-symdir* lisp-patterns)) (combine-path (list *maxima-symdir* maxima-patterns)))) - (setq cl-info::*info-paths* (list (concatenate 'string *maxima-infodir* "/"))) - ;; Share subdirs are not required here since all .info files are installed - ;; in one directory *maxima-infodir* -- there is no info files in share. - ;; vvzhy Jan 2, 2006 - ;(setq L (mapcar #'(lambda (x) (concatenate 'string *maxima-sharedir* "/" x "/")) share-subdirs-list)) - ;(setq cl-info::*info-paths* (append cl-info::*info-paths* L)) - - ; Look for "foo.info" in share directory "foo". - (loop for d in share-subdirs-list do - (let ((name (if (find #\/ d) (unix-like-basename d) d))) - (when (cl-info::file-search name cl-info::*info-paths* '("info") nil) - #+debug (format t "SET-PATHNAMES: found an info file for share directory ~S~%" name) - (nconc cl-info::*default-info-files* `(,(concatenate 'string name ".info")))))))) + (let + ((subdir-bit (if (null *maxima-lang-subdir*) "" (concatenate 'string "/" *maxima-lang-subdir*)))) + (autof 'cl-info::cause-maxima-index-to-load + (concatenate 'string *maxima-infodir* subdir-bit "/maxima-index.lisp"))))) (defun get-dirs (path) #+(or :clisp :sbcl) @@ -587,8 +561,8 @@ (setf *read-default-float-format* 'lisp::double-float)) (catch 'to-lisp - (set-pathnames) (set-locale) + (set-pathnames) (setf (values input-stream batch-flag) (process-maxima-args input-stream batch-flag)) (progn Index: macdes.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/macdes.lisp,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- macdes.lisp 4 Jan 2006 11:19:45 -0000 1.29 +++ macdes.lisp 29 Nov 2006 05:35:03 -0000 1.30 @@ -130,27 +130,14 @@ ;; versions of maxima have a builtin info retrieval mechanism. (defmspec $describe (x) - (setq x ($sconcat (cadr x))) - (let ((cl-info::*prompt-prefix* *prompt-prefix*) - (cl-info::*prompt-suffix* *prompt-suffix*) - (cl-info::*lang-subdir* *maxima-lang-subdir*)) - #-gcl - (cl-info:info x) - ;; Optimization: GCL's built-in info is much faster than our info - ;; implementation. However, GCL's info won't respect out *prompt- - ;; variables. Compromise by only calling our info when the prompts - ;; are not empty. --jfa 07/25/04 - ;; We have to use Maxima info for GCL, at least temorarily, since - ;; GCL's info is not quite compatible (GCL 2.6.6) with recent - ;; texinfo releases. -- ZW 01-Apr-05 - #+gcl - (cl-info:info x) - #+nil - (if (and (string= *prompt-prefix* "") (string= *prompt-suffix* "")) - (progn - (setf system::*info-paths* cl-info:*info-paths*) - (system::info x '("maxima.info"))) - (cl-info:info x)))) + (let + ((topic ($sconcat (cadr x))) + (exact-p (eq (caddr x) '$exact)) + (cl-info::*prompt-prefix* *prompt-prefix*) + (cl-info::*prompt-suffix* *prompt-suffix*)) + (if exact-p + (cl-info::info-exact topic) + (cl-info::info topic)))) (defun $apropos ( s ) (cons '(mlist) (apropos-list s :maxima))) Index: maxima-package.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/maxima-package.lisp,v retrieving revision 1.28 retrieving revision 1.29 diff -u -d -r1.28 -r1.29 --- maxima-package.lisp 25 Mar 2006 22:14:27 -0000 1.28 +++ maxima-package.lisp 29 Nov 2006 05:35:03 -0000 1.29 @@ -10,8 +10,7 @@ )) (defpackage :cl-info - (:use :common-lisp :maxima-nregex) - (:export #:info #:*info-paths*)) + (:use :common-lisp)) (defpackage :command-line (:use :common-lisp) Index: mdebug.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/mdebug.lisp,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- mdebug.lisp 10 Nov 2006 16:28:53 -0000 1.27 +++ mdebug.lisp 29 Nov 2006 05:35:03 -0000 1.28 @@ -343,6 +343,14 @@ (subseq (read-line stream eof-error-p eof-value) 1)))) `((displayinput) nil (($describe) ,line)))) + ((equal next #\!) + ;; We have "?!...". Assume it is "?! <stuff>", + ;; so invoke INFO-EXACT on <stuff>. + (let* ((line (string-trim + '(#\space #\tab #\; #\$) + (subseq + (read-line stream eof-error-p eof-value) 1)))) + `((displayinput) nil (($describe) ,line $exact)))) (t ;; Got "?<stuff>" This means a call to a Lisp ;; function. Pass this on to mread which can handle |