From toy@rtp.ericsson.se Fri Mar 30 16:04:02 2001 MIME-Version: 1.0 To: wfs@mail.ma.utexas.edu Subject: Re: CMUCL patches! From: Raymond Toy Date: 30 Mar 2001 17:03:43 -0500 --=-=-= >>>>> "Bill" == Bill Schelter writes: Bill> Thank you very much for the patches. Bill> I have added them to the cvs exactly as submitted. Bill> I have put a patched version of the maxima-5.5 under Thank you! I now have a few more patches for you and a couple of new files. New files: cmulisp-regex: An interface to GNU regex. cl-info: A port of gcl's info.lsp to CMUCL. Uses cmulisp-regex. Along with these changes are some patches to get describe to work on CMUCL. Changelog: compile-cmulisp.lisp: o Add some text to explain how to build it. o Add support for maxima's describe. o Changed the name of the core file to maxima.core. macdes.lisp: o Add $describe for CMUCL. init_max1.lisp: o Changed SYSTEM:: to SI:: o Set up file extensions appropriately for searching. o Update user::run to load up the foreign code so describe works. mload.lisp: o In $file_search, symbols are passed to probe-file and friends. Convert to strings. o In new-file-search, pass a string instead of NIL to new-file-search1. mactex.lisp: o Make tex(1.2e20) work on CMUCL, and change the output to 1.2 \times 10^{20} instead of \cdot. clmacs.lisp: o most-positive-fixnum is too large a count for CMUCL in delq and zl-remove. Ray --=-=-= Content-Disposition: attachment; filename=cmulisp-regex.lisp ;;; ;;; Alien interface to GNU regex, for CMUCL ;;; ;;; (in-package "REGEX") (export '( ;; Constants +re-backslash-escape-in-lists+ +re-bk-plus-qm+ +re-char-classes+ +re-context-indep-anchors+ +re-context-indep-ops+ +re-context-invalid-ops+ +re-dot-newline+ +re-dot-not-null+ +re-hat-lists-not-newline+ +re-intervals+ +re-limited-ops+ +re-newline-alt+ +re-no-bk-braces+ +re-no-bk-parens+ +re-no-bk-refs+ +re-no-bk-vbar+ +re-no-empty-ranges+ +re-unmatched-right-paren-ord+ ;; Common regexp syntaxes +re-syntax-emacs+ +re-syntax-egrep+ +re-syntax-posix-common+ +re-syntax-posix-basic+ +re-syntax-posix-extended+ +re-syntax-spencer+ ;; Variables *match-data* *case-fold-search* ;; Functions match-data-start match-data-end string-match match-beginning match-end )) (use-package "ALIEN") (use-package "C-CALL") #+nil (eval-when (:load-toplevel :compile-toplevel :execute) (ext:load-foreign "/apps/gnu/src/regex-0.12/regex.o") ) ;;; From regex.h ;; GNU interface (def-alien-type reg-syntax-t unsigned) (def-alien-type re-pattern-buffer (struct re-pattern-buffer (buffer (* unsigned-char)) (allocated unsigned) (used unsigned) (syntax unsigned) (fastmap (* unsigned-char)) (translate (* unsigned-char)) (re-nsub int) (bit-fields int))) (def-alien-type re-registers (struct re-registers (num-regs unsigned) (start (* int)) (end (* int)))) (declaim (inline re-compile-pattern)) (def-alien-routine ("re_compile_pattern" re-compile-pattern) c-string (pattern c-string) (length int) (buffer (* re-pattern-buffer))) (declaim (inline re-match)) (def-alien-routine ("re_match" re-match) int (buffer (* re-pattern-buffer)) (string c-string) (length int) (start int) (regs (* re-registers))) (declaim (inline re-set-registers)) (def-alien-routine ("re_set_registers" re-set-registers) void (buffer (* re-pattern-buffer)) (regs (* re-registers)) (num-regs unsigned) (starts (* int)) (ends (* int))) (declaim (inline re-regfree)) (def-alien-routine ("regfree" re-regfree) void (regs (* re-pattern-buffer))) (declaim (inline re-search)) (def-alien-routine ("re_search" re-search) int (buffer (* re-pattern-buffer)) (string c-string) (length int) (start int) (range int) (regs (* re-registers))) (def-alien-variable ("re_syntax_options" re-syntax-options) reg-syntax-t) ;;; POSIX interface #| (def-alien-type regex-t re-pattern-buffer) (def-alien-type regoff-t int) (def-alien-type regmatch-t (struct regmatch-t (rm-so int) (rm-eo int))) (declaim (inline re-regcomp)) (def-alien-routine ("regcomp" re-regcomp) int (preg (* regex-t)) (regex c-string) (cflags int)) (declaim (inline re-regexec)) (def-alien-routine ("regexec" re-regexec) int (preg (* regex-t)) (string c-string) (nmatch int) (pmatch (array regmatch-t) :in-out) (eflags int)) (declaim (inline re-regerror)) (def-alien-routine ("regerror" re-regerror) int (errcode int) (preg (* regex_t)) (errbuf c-string) (errbuf-size int)) |# (macrolet ((frob (&rest name-desc-list) `(progn ,@(let ((bit 1)) (mapcar #'(lambda (name-desc) (prog1 `(defconstant ,(first name-desc) ,bit ,(second name-desc)) (setf bit (ash bit 1)))) name-desc-list))))) (frob (+re-backslash-escape-in-lists+ "If this bit is not set, then \\ inside a bracket expression is literal. If set, then such a \\ quotes the following character. ") (+re-bk-plus-qm+ "If this bit is not set, then + and ? are operators, and \\+ and \\? are literals. If set, then \\+ and \\? are operators and + and ? are literals.") (+re-char-classes+ "If this bit is set, then character classes are supported. They are: [:alpha:], [:upper:], [:lower:], [:digit:], [:alnum:], [:xdigit:],[:space:], [:print:], [:punct:], [:graph:], and [:cntrl:]. If not set, then character classes are not supported.") (+re-context-indep-anchors+ "If this bit is set, then ^ and $ are always anchors (outside bracket expressions, of course). If this bit is not set, then it depends: ^ is an anchor if it is at the beginning of a regular expression or after an open-group or an alternation operator; $ is an anchor if it is at the end of a regular expression, or before a close-group or an alternation operator. ") (+re-context-indep-ops+ "") (+re-context-invalid-ops+ "") (+re-dot-newline+ "") (+re-dot-not-null+ "") (+re-hat-lists-not-newline+ "") (+re-intervals+ "") (+re-limited-ops+ "") (+re-newline-alt+ "") (+re-no-bk-braces+ "") (+re-no-bk-parens+ "") (+re-no-bk-refs+ "") (+re-no-bk-vbar+ "") (+re-no-empty-ranges+ "") (+re-unmatched-right-paren-ord+ ""))) (defconstant +re-syntax-emacs+ 0) (defconstant +re-syntax-egrep+ (logior +re-char-classes+ +re-context-indep-anchors+ +re-context-indep-ops+ +re-hat-lists-not-newline+ +re-newline-alt+ +re-no-bk-parens+ +re-no-bk-vbar+)) (defconstant +re-syntax-posix-common+ (logior +re-char-classes+ +re-dot-newline+ +re-dot-not-null+ +re-intervals+ +re-no-empty-ranges+)) (defconstant +re-syntax-posix-basic+ (logior +re-syntax-posix-common+ +re-bk-plus-qm+)) (defconstant +re-syntax-posix-extended+ (logior +re-syntax-posix-common+ +re-context-indep-anchors+ +re-context-indep-ops+ +re-no-bk-braces+ +re-no-bk-parens+ +re-no-bk-vbar+ +re-unmatched-right-paren-ord+)) (defconstant +re-syntax-spencer+ (logior +re-no-bk-parens+ +re-no-bk-vbar+)) #+nil (defun allocate-re-regs (compiled-pattern-buffer) (declare (type (alien (* re-pattern-buffer)) compiled-pattern-buffer)) (let* ((nregs (1+ (slot compiled-pattern-buffer 're-nsub))) (re-regs (make-alien re-registers 1)) (reg-start (make-alien int nregs)) (reg-end (make-alien int nregs))) (re-set-registers compiled-pattern-buffer re-regs nregs reg-start reg-end) (ext:finalize re-regs #'(lambda () (format t "~&freeing re-regs~%") (free-alien (slot (deref re-regs 0) 'start)) (free-alien (slot (deref re-regs 0) 'end)) )) re-regs)) (defun allocate-re-regs () (make-alien re-registers 1)) (defun free-re-regs (re-regs) (declare (type (alien (* re-registers)) re-regs)) (let ((r (deref re-regs))) (free-alien (slot r 'start)) (free-alien (slot r 'end)) (free-alien re-regs))) (defun make-case-fold-table () "Translation table to fold all uppercase ASCII characters to lower case characters" (let ((tab (make-alien (unsigned 8) 256))) ;; Initialize the table to the 256 ASCII characters (dotimes (k 256) (setf (deref tab k) k)) ;; Translate the upper case characters to lower case (loop for k from (char-int #\A) to (char-int #\Z) do (setf (deref tab k) (- k #.(- (char-int #\A) (char-int #\a))))) tab)) (defvar *match-data* nil "The match-data from the latest successful string-match") (declaim (type (or null (simple-array t (*))) *match-data*)) (defvar *case-fold-search* nil "Non-NIL if the character case should be folded during searchs") (defun allocate-re-pattern-buffer () (let* ((pat-buf-ptr (make-alien re-pattern-buffer 1)) (pat-buf (deref pat-buf-ptr 0))) ;; Set BUFFER to NIL and ALLOCATED to 0 so re_compile_pattern ;; allocates space for us. (setf (slot pat-buf 'buffer) nil) (setf (slot pat-buf 'allocated) 0) ;; We don't support fastmap (setf (slot pat-buf 'fastmap) (make-alien unsigned-char 256)) ;; Set case folding appropriately (setf (slot pat-buf 'translate) (if *case-fold-search* (make-case-fold-table) nil)) pat-buf-ptr)) (defun dump-compiled-pattern (compiled-pattern) (declare (type (alien (* re-pattern-buffer)) compiled-pattern)) (let ((pat-buf (deref compiled-pattern))) (format t "buffer = ~S~%" (slot pat-buf 'buffer)) (format t "allocated = ~S~%" (slot pat-buf 'allocated)) (format t "used = ~S~%" (slot pat-buf 'used)) (format t "syntax = ~S~%" (slot pat-buf 'syntax)) (format t "fastmap = ~S~%" (slot pat-buf 'fastmap)) (format t "re-nsub = ~S~%" (slot pat-buf 're-nsub)) (format t "translate = ~S~%" (slot pat-buf 'translate)) (format t "bit-fields = ~:42,' ,' ,4B~%" (slot pat-buf 'bit-fields)) )) (defun compile-pattern (pattern-string) (declare (type string pattern-string)) (let* ((pat-buf (allocate-re-pattern-buffer)) (comp (re-compile-pattern pattern-string (length pattern-string) pat-buf))) (when comp (unwind-protect (error "~A in regexp ~S" comp pattern-string) ;; Free up the pattern buffer (re-regfree pat-buf) (free-alien pat-buf))) pat-buf)) (defstruct match-data (start 0 :type (unsigned-byte 32)) (end 0 :type (unsigned-byte 32))) ;; Copy the data in the alien re-register to a lisp array (defun lispify-match-data (nsub re-regs) (declare (fixnum nsub) (type (alien (* re-registers)) re-regs)) (let* ((regs (deref re-regs)) (start (slot regs 'start)) (end (slot regs 'end)) (matches (make-array nsub))) (dotimes (k nsub) (setf (aref matches k) (make-match-data :start (deref start k) :end (deref end k)))) matches)) (defun string-match (pattern string &optional (start 0) end (syntax +re-syntax-spencer+)) "Search the string STRING for the first pattern that matches the regexp PATTERN. The syntax used for the pattern is specified by SYNTAX. The search may start in the string at START and ends at END, which default to 0 and the end of the string. If there is a match, returns the index of the start of the match and an array of match-data. If there is no match, -1 is returned and nil." (declare (type string pattern string)) (setf re-syntax-options syntax) (let* ((comp-result (compile-pattern pattern))) ;; Make sure we free up the space for the pattern buffer. (unwind-protect (progn (cond (comp-result (let* ((re-regs (allocate-re-regs))) ;; Make sure we free up the space for the registers (unwind-protect (progn (let ((search-result (re-search comp-result string (length string) start (or end (length string)) re-regs))) (cond ((>= search-result 0) (let ((matches (lispify-match-data (1+ (slot (deref comp-result) 're-nsub)) re-regs))) ;; Save the last match in the global var (setf *match-data* matches) (values search-result matches))) (t (values search-result nil))))) ;; Free up the re-register since we're done with it now. (free-re-regs re-regs)))) (t (setf *match-data* nil) (values -1 nil)))) ;; Free the pattern buffer (re-regfree comp-result) (free-alien comp-result)))) (defun match-beginning (index &optional (match-data *match-data*)) (if (and match-data (< index (length match-data))) (match-data-start (aref match-data index)) -1)) (defun match-end (index &optional (match-data *match-data*)) (if (and match-data (< index (length match-data))) (match-data-end (aref match-data index)) -1)) --=-=-= Content-Disposition: attachment; filename=cl-info.lisp ;;; This is port of GCL's info.lsp to CMUCL. This should basically be ;;; portable Common Lisp, but I haven't tested it with anything else. (in-package "SI") (use-package "REGEX") (declaim (optimize (safety 3) (debug 3))) (eval-when (compile eval) (defmacro while (test &body body) `(loop while ,test do ,@ body)) (defmacro f (op x y) `(,op (the fixnum ,x) (the fixnum ,y)))) (eval-when (compile eval load) (defun sharp-u-reader (stream subchar arg) subchar arg (let ((tem (make-array 10 :element-type 'base-char :fill-pointer 0))) (or (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 base-char (*))))) (set-dispatch-macro-character #\# #\u 'sharp-u-reader) ) (defvar *info-data* nil) (defvar *current-info-data* nil) (defun file-to-string (file &optional (start 0)) (with-open-file (st file) (let ((len (file-length st))) (or (and (<= 0 start ) (<= start len)) (error "illegal file start ~a" start)) (let ((tem (make-array (- len start) :element-type 'base-char))) (if (> start 0) (file-position st start)) (read-sequence tem st :start 0 :end (length tem)) tem)))) (defun atoi (string start) (declare (string string)) (declare (fixnum start)) (let ((ans 0) (ch 0) (len (length string))) (declare (fixnum ans ch len)) (while (< start len) (setq ch (char-code (aref string start))) (setq start (+ start 1)) (setq ch (- ch #.(char-code #\0))) (cond ((and (>= ch 0) (< ch 10)) (setq ans (+ ch (* 10 ans)))) (t (return nil)))) ans)) (defun info-get-tags (file &aux (lim 0) *match-data* tags files (*case-fold-search* t)) (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)) (cond ((f >= (string-match #u"[ \n]+Indirect:" s 0) 0) (setq i (match-end 0)) (setq lim (string-match #u"" s i)) (while (f >= (string-match #u"\n([^\n]+): ([0-9]+)" s i lim) 0) (setq i (match-end 0)) (setq files (cons (cons (atoi s (match-beginning 2)) (get-match s 1) ) files))))) (cond ((f >= (string-match #u"[\n ]+Tag Table:" s i) 0) (setq i (match-end 0)) (cond ((f >= (string-match "" s i) 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)))) (defun re-quote-string (x &aux (i 0) (len (length x)) ch (extra 0) ) (declare (fixnum i len extra)) (declare (string x)) (let (tem) (tagbody AGAIN (while (< i len) (setq ch (aref x i)) (cond ((position ch "\\()[]+.*|^$?") (cond (tem (vector-push-extend #\\ tem)) (t (incf extra))))) (if tem (vector-push-extend ch tem)) (setq i (+ i 1))) (cond (tem ) ((> extra 0) (setq tem (make-array (f + (length x) extra) :element-type 'base-char :fill-pointer 0)) (setq i 0) (go AGAIN)) (t (setq tem x))) ) tem)) (defun get-match (string i) (subseq string (match-beginning i) (match-end i))) (defun string-concatenate (&rest strings) (apply #'concatenate 'string strings)) (defun get-nodes (pat node-string &aux (i 0) ans (*case-fold-search* t) *match-data*) (declare (fixnum i)) (when node-string (setq pat (string-concatenate "Node: ([^]*" (re-quote-string pat) "[^]*)")) (while (f >= (string-match 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 (get-nodes "index" node-string))))) (when node (setq s (show-info node nil)) (setf (third *current-info-data*) s))))) (defun nodes-from-index (pat &aux (i 0) ans (*case-fold-search* t) *match-data*) (let ((index-string (get-index-node))) (when index-string (setq pat (string-concatenate #u"\n\\* ([^:\n]*" (re-quote-string pat) #u"[^:\n]*):[ \t]+([^\t\n,.]+)")) (while (f >= (string-match pat index-string i) 0) (setq i (match-end 0)) (setq ans (cons (cons (get-match index-string 1) (get-match index-string 2)) ans)) ) (nreverse ans)))) (defun get-node-index (pat node-string &aux (node pat) *match-data*) (cond ((null node-string) 0) (t (setq pat (string-concatenate "Node: " (re-quote-string pat) "([0-9]+)")) (cond ((f >= (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 &aux (start 0) *match-data*) (declare (fixnum start)) (loop while (>= (setq start (string-match pat st start)) 0) do 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))) (defvar *info-paths* '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/" "/usr/local/gnu/info/" )) (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 (make-pathname :directory dir))) (dolist (type extensions) (let ((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 &aux tem file) #+nil (unless (eq *old-lib-directory* si::*lib-directory*) (setq *old-lib-directory* si::*lib-directory*) (push (string-concatenate si::*lib-directory* "info/") *info-paths*) (setq *info-paths* (si::fix-load-path *info-paths*))) (cond ((or (equal name "DIR")) (setq name "dir"))) (setq file (file-search name *info-paths* '("" ".info") nil)) (cond ((and (null file) (not (equal name "dir"))) (let* ((tem (show-info "(dir)Top" nil)) *case-fold-search*) (cond ((f >= (string-match (string-concatenate "\\(([^(]*" (re-quote-string name) "(.info)?)\\)") tem ) 0) (setq file (get-match tem 1))))))) (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 "(not found ~s)" name))) 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) (defvar *info-window* nil) (defvar *tk-connection* nil) (defun info-error (&rest l) (apply #'error l)) (defvar *last-info-file* nil) ;; cache last file read to speed up lookup since may be gzipped.. (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 &aux ) ; "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) (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 (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 (f >= (string-match #u"" s i end) 0) (setq i (match-end 0))) (setq i (- i 1)) (if (f >= (string-match #u"[\n ][^\n]*Node:[ \t]+([^\n\t,]+)[\n\t,][^\n]*\n" s i) 0) (let* ((i (match-beginning 0)) (beg (match-end 0)) (name (get-match s 1)) (end(if (f >= (string-match "[ ]" s beg) 0) (match-beginning 0) (length s))) (node (list* s beg end i name info-subfile *current-info-data*))) node)))) (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))) (or (stringp name) (info-error "bad arg")) (when (f >= (string-match "^\\(([^(]+)\\)([^)]*)" 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)))) (cond ((f >= (string-match ;; to do fix this ;; see (info)Add for description; ;; the (string-concatenate #u"[\n ][^\n]*Node:[ \t]+" (re-quote-string name) #u"[,\t\n][^\n]*\n") s start) 0) (let* ((i (match-beginning 0)) (beg (match-end 0)) (end (if (f >= (string-match "[ ]" s beg) 0) (match-beginning 0) (length s))) (node (list* s beg end i name info-subfile *current-info-data*))) (cond (position-pattern (setq position-pattern (re-quote-string position-pattern)) (let (*case-fold-search* ) (if (or (f >= (setq subnode (string-match (string-concatenate #u"\n - [A-Za-z ]+: " position-pattern #u"[ \n]") s beg end)) 0) (f >= (string-match position-pattern s beg end) 0)) (setq initial-offset (- (match-beginning 0) beg)) )))) (cond (t (let ((e (if (and (>= subnode 0) (f >= (string-match #u"\n - [A-Z]" s (+ beg 1 initial-offset) end) 0)) (match-beginning 0) end))) ;(print (list beg initial-offset e end)) (subseq s (+ initial-offset beg) e ) ;s ))))) (t (info-error "Can't find node ~a?" name))))))) (defvar *default-info-files* '( "gcl-si.info" "gcl-tk.info" "gcl.info")) (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 end &aux limit) ; "search for PATTERN from START up to END where these are indices in ;the general info file. The search goes over all files." (or start (setq start 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))) (cond ((f >= (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 nil)))))) (defun info (x &optional (dirs *default-info-files*) &aux wanted *current-info-data* file position-pattern) (let ((tem (info-aux x dirs))) (cond (*tk-connection* (offer-choices tem dirs) ) (t (when tem (loop for i from 0 for name in tem with prev do (setq file nil position-pattern nil) (progn ;decode name (cond ((and (consp name) (consp (cdr name))) (setq file (cadr name) name (car name)))) (cond ((consp name) (setq position-pattern (car name) name (cdr name))))) (format t "~% ~d: ~@[~a :~]~@[(~a)~]~a." i position-pattern (if (eq file prev) nil (setq prev file)) name)) (format t "~%Enter n, all, none, or multiple choices eg 1 3 : ") (let ((line (read-line)) (start 0) val) (while (equal line "") (setq line (read-line))) (while (multiple-value-setq (val start) (read-from-string line nil nil :start start)) (cond ((numberp val) (setq wanted (cons val wanted))) (t (setq wanted val) (return nil)))) (cond ((consp wanted)(setq wanted (nreverse wanted))) ((symbolp wanted) (setq wanted (and (equal (symbol-name wanted) "ALL") (loop for i below (length tem) collect i))))) (if wanted (format t "~%Info from file ~a:" (car *current-info-data*))) (loop for i in wanted do (princ(show-info (nth i tem))))))))) (values)) ;; 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 ;; (defun default-info-hotlist() (namestring (merge-pathnames "hotlist" (user-homedir-pathname)))) (defvar *info-window* nil) (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 favrite info items.\n\n" st))) (format st "* (~a)~a::~%" (node file node)(node name node)))))) (defun list-matches (s &rest l) (loop for i in l collect (and (f >= (match-beginning i) 0) (get-match s i)))) ;;; Local Variables: *** ;;; mode:lisp *** ;;; version-control:t *** ;;; comment-column:0 *** ;;; comment-start: ";;; " *** ;;; End: *** --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=max.patch --- maxima-5.5/src/compile-cmulisp.lisp Wed Feb 28 17:48:11 2001 +++ cmucl-maxima-5.5/src/compile-cmulisp.lisp Fri Mar 30 16:19:15 2001 @@ -1,19 +1,99 @@ +;;; +;;; To compile Maxima with CMUCL, load this file. Then +;;; (compile-maxima) to compile everything. Then (save-maxima) +;;; to save a core file. +;;; +;;; If you want support for maxima describe command, you need to get a +;;; copy of GNU regex and compile and install it. Change the path +;;; user::run in init_max1.lisp to the appropriate location of +;;; regex.o. +;;; +;;; Also, for things to work, you really need to have a dir file in +;;; the same location as the maxima.info file. +;;; +;;; Finally, you need to set MAXIMA_DIRECTORY appropriately before +;;; running maxima. This should be the top-level directory of the +;;; maxima sources. Either here or wherever you installed maxima. +;;; (See the maxima shell script if you installed maxima with gcl for +;;; an appropriate value.) +;;; + +(defpackage "SI" + (:use "COMMON-LISP" "ALIEN" "C-CALL")) + +(defpackage "REGEX" + (:use "COMMON-LISP" "ALIEN" "C-CALL") + (:export + ;; Constants + "+RE-BACKSLASH-ESCAPE-IN-LISTS+" + "+RE-BK-PLUS-QM+" + "+RE-CHAR-CLASSES+" + "+RE-CONTEXT-INDEP-ANCHORS+" + "+RE-CONTEXT-INDEP-OPS+" + "+RE-CONTEXT-INVALID-OPS+" + "+RE-DOT-NEWLINE+" + "+RE-DOT-NOT-NULL+" + "+RE-HAT-LISTS-NOT-NEWLINE+" + "+RE-INTERVALS+" + "+RE-LIMITED-OPS+" + "+RE-NEWLINE-ALT+" + "+RE-NO-BK-BRACES+" + "+RE-NO-BK-PARENS+" + "+RE-NO-BK-REFS+" + "+RE-NO-BK-VBAR+" + "+RE-NO-EMPTY-RANGES+" + "+RE-UNMATCHED-RIGHT-PAREN-ORD+" + ";; COMMON REGEXP SYNTAXES" + "+RE-SYNTAX-EMACS+" + "+RE-SYNTAX-EGREP+" + "+RE-SYNTAX-POSIX-COMMON+" + "+RE-SYNTAX-POSIX-BASIC+" + "+RE-SYNTAX-POSIX-EXTENDED+" + "+RE-SYNTAX-SPENCER+" + ;; Variables + "*MATCH-DATA*" + "*CASE-FOLD-SEARCH*" + ;; Functions + "MATCH-DATA-START" + "MATCH-DATA-END" + "STRING-MATCH" + "MATCH-BEGINNING" + "MATCH-END" + )) + (push :main-files-loaded *features*) (load "sysdef.lisp") (load "make.lisp") (defun compile-maxima () + (compile-file "cmulisp-regex") + (compile-file "cl-info") (make::make :maxima :compile t)) (defun save-maxima () + ;;(load "cmulisp-regex" :if-source-newer :compile) + ;;(load "cl-info" :if-source-newer :compile) (make::make :maxima) + (setq maxima::*maxima-directory* (namestring (truename "../"))) + (load "init_max1") (ext:gc) - (ext:save-lisp "maxima-cmulisp.mem" :init-function #'user::run + (ext:save-lisp "maxima.core" :init-function #'user::run :load-init-file nil :site-init nil)) (in-package "MAXIMA") +(defvar maxima::*maxima-directory* nil) + +#+nil +(ext:defswitch "dir" + #'(lambda (switch) + (let ((dirpath (ext:cmd-switch-arg switch))) + ;; Make sure it ends with a slash + (setf *maxima-directory* + (if (eql (aref dirpath (1- (length dirpath))) #\/) + dirpath + (concatenate 'string dirpath "/")))))) ;; define bye so that quit() will work in maxima (defun bye () (ext:quit)) --- maxima-5.5/src/macdes.lisp Fri Feb 23 21:11:09 2001 +++ cmucl-maxima-5.5/src/macdes.lisp Fri Mar 30 15:27:12 2001 @@ -130,3 +130,19 @@ on GCL have a builtin info retrieval mechanism" )) ) +#+cmu +(progn + +(defun $describe(x &aux (si::*info-paths* si::*info-paths*)) + (setq x ($sconcat x)) + (setq SYSTEM::*INFO-PATHS* + (cons (concatenate 'string *maxima-directory* + "info/") + SYSTEM::*INFO-PATHS*)) + (if (fboundp 'si::info) + (si::info x '("maxima.info")) + "The documentation is now in INFO format and can be printed using +tex, or viewed using info or gnu emacs. Versions of maxima built +on GCL or CMUCL have a builtin info retrieval mechanism" )) +) + --- maxima-5.5/src/init_max1.lisp Fri Mar 30 12:05:24 2001 +++ cmucl-maxima-5.5/src/init_max1.lisp Fri Mar 30 15:53:32 2001 @@ -62,15 +62,21 @@ (si::argv 0))) "../")))))) - (or (boundp 'SYSTEM::*INFO-PATHS*) (setq SYSTEM::*INFO-PATHS* nil) ) - (push (maxima-path "info" "") SYSTEM::*INFO-PATHS*) - (setq $file_search_lisp - (list '(mlist) - "./###.{o,lsp,lisp}" - (maxima-path "{src,share1,sym}" "###.o") - (maxima-path "{src,share1,sym}" "###.o") - (maxima-path "{src,share1}" "###.lisp") - (maxima-path "{sym}" "###.lsp"))) + (or (boundp 'SI::*INFO-PATHS*) (setq SI::*INFO-PATHS* nil) ) + (push (maxima-path "info" "") SI::*INFO-PATHS*) + (let ((ext #+gcl "o" + #+cmu (c::backend-fasl-file-type c::*target-backend*) + #-(or gcl cmu) + "")) + (setq $file_search_lisp + (list '(mlist) + (format nil "./###.{~A,lsp,lisp}" ext) + (maxima-path "{src,share1,sym}" + (concatenate 'string "###." ext)) + (maxima-path "{src,share1,sym}" + (concatenate 'string "###." ext)) + (maxima-path "{src,share1}" "###.lisp") + (maxima-path "{sym}" "###.lsp")))) (setq $file_search_maxima (list '(mlist) "./###.{mc,mac}" @@ -89,12 +95,28 @@ (maxima-path "sym" "")) )) + +#+gcl (defun user::run () (in-package "MAXIMA") (catch 'to-lisp (set-pathnames) (macsyma-top-level) )) + +#+cmu +(defun user::run () + ;; Turn off gc messages + (setf ext:*gc-verbose* nil) + ;; Reload the documentation stuff + (ext:load-foreign "/apps/gnu/src/regex-0.12/regex.o") + (load "cmulisp-regex" :if-source-newer :compile) + (load "cl-info" :if-source-newer :compile) + (in-package "MAXIMA") + (catch 'to-lisp + (set-pathnames) + (macsyma-top-level))) + (import 'user::run) ($setup_autoload "eigen.mc" '$eigenvectors '$eigenvalues) #+gcl --- maxima-5.5/src/mload.lisp Tue Feb 27 22:45:51 2001 +++ cmucl-maxima-5.5/src/mload.lisp Fri Mar 30 15:57:46 2001 @@ -852,11 +852,11 @@ ;; the path. A template may use multiple {a,b,c} constructions to indicate ;; multiple possiblities. eg foo.l{i,}sp or foo.{dem,dm1,dm2} (defun $file_search (name &optional paths) - (if (probe-file name) (return-from $file_search name)) + (if (probe-file (string name)) (return-from $file_search name)) (or paths (setq paths ($append $file_search_lisp $file_search_maxima $file_search_demo))) (atomchk paths '$file_search t) - (new-file-search name (cdr paths))) + (new-file-search (string name) (cdr paths))) (defun new-file-search (name template &aux lis temp) (cond ((probe-file name)) @@ -869,7 +869,7 @@ collect w else collect (split-string w ","))) - (new-file-search1 nil lis)) + (new-file-search1 "" lis)) (t (sloop for v in template when (setq temp (new-file-search name v)) do (return temp))))) @@ -923,4 +923,4 @@ )) - \ No newline at end of file + --- maxima-5.5/src/mactex.lisp Mon May 8 02:09:41 2000 +++ cmucl-maxima-5.5/src/mactex.lisp Fri Mar 30 16:04:01 2001 @@ -237,19 +237,29 @@ (intern tem))) - +#+cmu +(defun strcat (&rest args) + (apply #'concatenate 'string (mapcar #'string args))) -(defun texnumformat(atom) ;; 10/14/87 RJF convert 1.2e20 to 1.2 \cdot 10^{20} - (let(r firstpart exponent) - (cond ((integerp atom)atom) - (t (setq r (explode atom)) - (setq exponent (memq 'e r)) ;; is it ddd.ddde+EE - (cond ((null exponent) atom); it is not. go with it as given - (t (setq firstpart (nreverse (cdr (memq 'e (reverse r))))) - (strcat (apply #'strcat firstpart ) - "\\cdot 10^{" - (apply #'strcat (cdr exponent)) - "}"))))))) +;; 10/14/87 RJF convert 1.2e20 to 1.2 \cdot 10^{20} +;; 03/30/01 RLT make that 1.2 \times 10^{20} +(defun texnumformat(atom) + (let (r firstpart exponent) + (cond ((integerp atom) + atom) + (t + (setq r (explode atom)) + (setq exponent (member 'e r :test #'string-equal));; is it ddd.ddde+EE + (cond ((null exponent) + ;; it is not. go with it as given + atom) + (t + (setq firstpart + (nreverse (cdr (member 'e (reverse r) :test #'string-equal)))) + (strcat (apply #'strcat firstpart ) + " \\times 10^{" + (apply #'strcat (cdr exponent)) + "}"))))))) (defun tex-paren (x l r) (tex x (append l '("\\left(")) (cons "\\right)" r) 'mparen 'mparen)) --- maxima-5.5/src/clmacs.lisp Fri Feb 23 21:11:08 2001 +++ cmucl-maxima-5.5/src/clmacs.lisp Fri Mar 30 16:18:47 2001 @@ -244,6 +244,7 @@ (defun delq (x lis &optional (count most-positive-fixnum)) (declare (fixnum count)) #+lucid (setq count 16777214) ;;yukkk. + #+cmu (setq count (min count (1- most-positive-fixnum))) (delete x lis :test 'eq :count count)) (setf (symbol-function 'lsh) #'ash) @@ -360,6 +361,7 @@ (defun zl-remove (item list &optional (n most-positive-fixnum)) #+lucid (setq n 16777214) ;;yukkk. + #+cmu (setq n (min n (1- most-positive-fixnum))) ; yukkk (remove item list :count n :test 'equal)) (defvar *acursor* nil) --=-=-=--