Fix bug #3996: parse_string fails to parse string which contains semicolon

[maxima.git] / archive / src / macdes-prev.lisp

;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     The data in this file contains enhancments.                    ;;;;;
;;;                                                                    ;;;;;
;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
;;;     All rights reserved                                            ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "MAXIMA")

(defconstant *doc-start* (code-char 31))

(defun $example (item &optional (file
                                 (merge-pathnames "manual.demo"
                                                  $describe_documentation))
                      )
  (and (symbolp file) (setq file (stripdollar file)))
  (or (probe-file file)
      (return-from $example "Please supply a file name as the second arg"))
  (and (symbolp item) (setq item (symbol-name item))
       (setq item (subseq item 1))
       (with-open-file
        (st file)
        (sloop with tem
               while (setq tem (read-char st nil))
               do
               (cond ((and (eql tem #\&)
                           (eql (setq tem (read-char st nil)) #\&))
                      (cond
                       ((and (symbolp (setq tem (read st nil)))
                             (string-search item (symbol-name tem)))
                        (format t "~%Examples for ~a :~%" tem)
                        ;; This code fulls maxima into thinking that it just
                        ;; started, by resetting the values of the special
                        ;; variables $labels and $linenum to their initial
                        ;; values. They will be reset just after $example
                        ;; is done. The d-labels will also not be disturbed
                        ;; by calling example.
                        (progv 
                         ;; Protect the user labels and variables 
                         ;; from being voerwritten by creating a new 
                         ;; binding.
                         (append '($linenum
                                   $labels
                                   $values)
                                 (cdr $labels)
                                 (cdr $values))
                         (list 1
                               '((mlist simp))
                               '((mlist simp)))
                         ;; Run the example.
                         (unwind-protect
                             (sloop until
                                    (or (null (setq tem (peek-char nil st nil)))
                                        (eql tem #\&))
                                    for expr = (mread st nil)
                                    do
                                    (let ($display2d) (displa (third  expr)))
                                    ;; Make the c-label and d-label.
                                    (let ((c-label (makelabel $inchar))
                                          (d-label (makelabel $outchar)))
                                      ;; Set the c-label to the input
                                      ;; expression.
                                      (set c-label (third expr))
                                      (format t "<~d>==>" $linenum)
                                      (displa (setq $% (meval* (third  expr))))
                                      (set d-label $%)
                                      (incf $linenum)
                                      ))
                           ;; Clean-up form, which will be
                           ;; evaluated even if an error occurs,
                           ;; because of unwind-protect.  Kill
                           ;; all labels and values used the
                           ;; example. This is harmless, because
                           ;; the local binding established with
                           ;; progv is in effect.
                           (mapc #'makunbound
                                 (append
                                  (cdr $labels)
                                  (cdr $values))
                                 )))))))))))

  
(eval-when (compile eval load)

(defvar *pdp-describe* t "The file positioning is not so good for
 pdp type servers, because of character translation so we index more carefully.
 This should be ok for any file system")

;;this should really be in "macsyma-source:macsyma;macsym.doc" but I don't
;;want to copy it for here
     

(defmvar $describe_documentation #+lispm
  "maxima-documentation:maxima;macsym.doc"
  #-lispm "/usr/public/maxima/doc/macsym.doc"
  "This is the name of the main macsyma documentation file")



;;keep documentation on logical host maxima-documentation
(defmvar $all_macsyma_documentation
  (list'(mlist)
       $describe_documentation
       ))


;(defstruct (describe-index :named (:conc-name index-))
; documentation-file
;  entries)


(defstruct (describe-index (:type list) :named (:conc-name index-))
  documentation-file
  entries)

(defun make-entry (&key string file-pointer)
  (cons string file-pointer))

(defmacro key-string (x) `(car ,x))

(defmacro key-file-pointer (x) `(cdr , x))

;;The following assumes that :set-pointer will do something reasonable as
;;it does currently under chaos.  When and if we switch to tcp that will create
;;problems.  The reasonable strategy is then to switch to a line number
;;index and use a number of smaller files.  It took 37 seconds to read
;;once through the documentation file using tcp on the r20.

(defmacro read-1-char (st)
  `(let ((tem  (read-byte ,st nil nil)))
     (if tem (code-char tem))))


#+ti 
(defun file-position (a &optional b)
  (if b (send a :set-pointer b) (send a :read-pointer)))

(defun file-options (pathname) pathname
  #-lispm  (list  nil  8)
  #+lispm
   (case (send    (send pathname :host) :system-type)
            (:lispm (list  nil  8))
            (:tops-20 (error " can't use any more")(list  nil  7))
            (t (format t "~%Assuming byte-size 8 for making index") (list  nil  8)  )))

(defun index-file  ( file &aux
                          word (ch 0) cha   fil options ind)
  (setq fil (probe-file file))
  (setq options (file-options fil))
  (with-open-file
      (st file :element-type #+symbolics '(unsigned-byte 8)
          #-symbolics '(mod 256))
    (sloop while  ch
           when (eql (setq ch  (read-1-char st)) *doc-start* )
           do
           ;;the first character after *doc-start* is used to say what
           ;;kind of documentation this is.  This is compatible with
           ;;the gnu doc string files.
           (read-1-char st)
           (setq ind (file-position st))
           (setq word (with-output-to-string
                        (strin )
                        (sloop  until (zl-MEMBER
                                        (progn   
                                          (setq cha (read-1-char st))
                                          )
                                        '(#\space #\return #\newline nil)
                                        )
                                do
                                (tyo cha strin)
                                finally  (if cha (unread-char cha st))
                                )))
           and
           collecting   (make-entry :string
                                    (cond (
                                           (array-has-fill-pointer-p word)
                                           (subseq word 0
                                                   (length (the string  word))))
                                          (t word))
                                    :file-pointer ind) into llist
           finally
           (print (length llist))
           (return (make-describe-index
                             :documentation-file
                             (namestring file)
                             :entries  llist)))))

(defun font-number (ch)
  (cond ((char> ch #\*) (f- (char-code ch)#. (char-code #\0)))
        (t 0)))

(defun line-in (stream buffer end-char)
  (let ((tem (or buffer
                 (make-array 70 :fill-pointer 0 :element-type ' #.(array-element-type "abc")
                             :adjustable t
                             ))))
    (sloop with ch until
          (eql (setq ch (read-1-char stream)) end-char)  
          do (if (null ch) (loop-finish))
          (vector-push-extend ch tem))
    tem))



(defun read-item (stream file-pos  &key (up-to   *doc-start*) item (out-stream *standard-output*) &aux (prev-ch) (ch 0) lin)
  ;;have to set pointer to 0 for non lispm server.
  (cond ( *pdp-describe* (file-position stream 0)))
  (file-position stream file-pos)
  (setq lin (line-in stream nil #\newline))
  (cond ((and item  (null (string-search item lin))
              (y-or-n-p "~%Bad index file.  Try making a new one?"))
         (set-up-index (pathname stream) :make-new-one t)
         (error "now start over"))
        (t (format out-stream "~%~A~%" lin)))
  (sloop until (and (eql (setq ch (read-1-char stream))    ;(send stream :tyi))
                  up-to ) (eql prev-ch #\newline))
         while ch
        do (setq prev-ch ch)
        #-symbolics
        (cond ((char= ch #\\x06)
               (send stream :set-current-font (setq prev-ch (tyi stream)))))
        (tyo ch out-stream) ; (send out-stream :tyo ch)
        ))

(defvar *describe-indices* nil)
;;convention:use the same name for the documentation file as the index-name
(defun add-to-describe-indices (index-name describe-index &aux tem)
  (declare (special *index-path*))
  (setq index-name (string-downcase index-name))
  (and (boundp '*index-path*)
    (setf (index-documentation-file describe-index)
        (alter-pathname *index-path* :name index-name :type "doc")))
  (cond ((setq tem (zl-MEMBER index-name *describe-indices*))
         (setf (second tem) describe-index))
        (t (push describe-index *describe-indices*)
           (push index-name *describe-indices*))))

(defun set-up-index (file &key write-file-name make-new-one
                          &aux index-name index tem)
  (setq file (pathname file))
  #+kcl
  (or (probe-file file)
      (and (setq tem (alter-pathname file :directory
                                     (append
                                      (pathname-directory
                                       (pathname si::*system-directory*))
                                      (pathname-directory "../doc/"))))
           (probe-file tem)
           (setq file tem)
           ))
  
;  (setq index-name (string-upcase (pathname-name file)))
  (cond ((null write-file-name)
         (setq write-file-name
               (format nil "~a~a-index.~a"
                       *describe-index-directory*
                       (pathname-name file) *index-file-type*)))
        (t (setq write-file-name (alter-pathname write-file-name :type *index-file-type*))))
  (cond ((or make-new-one (null  (probe-file write-file-name)))
         (format t "~%Having to make a new index...")
         (setq index  (index-file file))
         (add-to-describe-indices index-name  index)
         (write-forms-to-file write-file-name 
                              (lisp:LIST (lisp:LIST 'add-to-describe-indices
                                                        index-name
                                                        (lisp:LIST
                                                          'QUOTE index)))
                              :in-package "MAXIMA" :type *index-file-type*))
        (t
         (let ((*index-path* write-file-name))
           (declare (special *index-path*))
           (load write-file-name)))))




(defun write-forms-to-file
  (file-name forms   &key
             ( in-package *package*) (type :lisp) &aux #+lispm tem) 
  (cond 
    ((eq type :lisp)
     (with-open-file (st (alter-pathname file-name :type "LISP") :direction :output)
       (format st ";;; - * - Mode:Lisp; Package:~A;Syntax:common-lisp  - * -~%" in-package)
       (format st "~%(in-package \"~a\")~%" in-package)
       (prin1 (cons 'progn forms) st) (pathname st)))
    #+lispm
    ((member type '(:bin :xfasl))
     (si::dump-forms-to-file (setq tem (alter-pathname file-name :type type))
       forms (list :package in-package)) tem)))


(defmvar *index-file-type* :lisp)

(defvar *describe-index-directory* #-lispm "/usr/public/maxima/doc/"
    #+lispm "cl-maxima-object:maxima;")


(defun cl-string (zl-string &aux (leng (length zl-string))  answ)
       (cond ((and  (> leng 0)
              (not (integerp(aref zl-string 0)))) zl-string)
             (t (setq answ (make-array leng :element-type ' #.(array-element-type "abc")))
                (sloop for i below leng
                      do (setf (aref answ i) (code-char (aref zl-string i))))
                answ)))

(defun add-main-macsyma-documentation ( &aux  file-name)
         (sloop for v in (cdr $all_macsyma_documentation)
               do
               (setq file-name (pathname v) )
               (cond ((not (MEMBER (pathname-name file-name)
                               *describe-indices* :test 'equalp))
                      (set-up-index file-name)))))
                                                                       
(defun maxima-union (&rest lists &aux test)
  (setq test (or (second (memq :test lists)) #'eq))
  (sloop for v in lists until (eql v :test)
        with answ = nil
        do (sloop for vv in v do (pushnew vv answ :test test))
 (return answ)))

(defun $describe ( items-to-describe &key editor
                                     (index-names 'use-all)
                                     &aux items done zl-SOME  all-files)
  (cond ((not (consp items-to-describe))
         (setq items-to-describe (list items-to-describe))))
  (setq items-to-describe (sloop for v in items-to-describe
                                 collecting (string-trim "&$" v)))
  (add-main-macsyma-documentation)
  (setq items (sloop for (name this-ind) on *describe-indices* by 'cddr  
                     when (or (eq index-names 'use-all)
                              (zl-MEMBER name index-names))
                     appending
                     (sloop for u in (index-entries this-ind)
                            when (sloop for v in items-to-describe
                                        when (string-search v (car u))
                                        do (loop-return t))
                            collecting
                            (cons (index-documentation-file this-ind) u))))

  (sloop for v in items
         for i from 0
         do (format *terminal-io* "~%~3D: ~A" i (key-string (cdr v))))
  (cond (items
         (sloop until done
                do
                (let ((*standard-input* *query-io*))
                  #+lispm(send *query-io* :send-if-handles :fresh-line)
                  #-lispm (terpri)
                  (format *query-io* "Enter a number, or a Maxima list of numbers,  all or none:")
;                 (setq zl-SOME (mread-noprompt ))
                  (setq zl-SOME (let ((*mread-prompt* ""))
                                  (dbm-read *standard-input* nil nil)))
                  (print (list 'zl-some zl-some))
                  )
                (cond ((atom zl-SOME)
                       (cond ((numberp zl-SOME) (setq zl-SOME (list zl-SOME)))
                             ((eq zl-some '$all)
                              (setq zl-SOME (sloop for i below
                                                   (length items)
                                                   collecting i)))
                             ((eq '$none zl-some) (setq zl-SOME nil))))
                      (($listp zl-SOME)(setq zl-SOME (cdr zl-SOME))))
                (cond ((null zl-SOME) (setq done t))
                      ((numberp (car zl-SOME))
                       (setq items (sloop for i in zl-SOME
                                          collecting  (nth i items)))
                       (setq all-files (maxima-union (mapcar 'car items)  :test 'equalp))
                       (sloop for fil in all-files
                              do (read-documentation
                                  (sloop for it in items
                                         when (equal (car it) fil)
                                         collecting (cdr it))
                                  fil :editor editor))
                       (setq done t)))))
        (t (format t "~%No keys contain the strings ~A" items-to-describe)))
  '$done)

(setf (symbol-function '$apropos) #'$describe)
(defun read-documentation (items file &key editor) editor
  (cond
    ((null items) nil)
    (t
     (with-open-file (stream file :element-type #+symbolics '(unsigned-byte 8) #-symbolics '(mod 256)
                             ;:byte-size 8.
                             )
       (let ((output (cond #+lispm
                           (editor
                            (zwei::REST-OF-INTERVAL-STREAM (zwei::POINT)))
                           (t *standard-output*))))
         (sloop for v in items
               do (read-item  stream (cdr v)
                              :out-stream output :item (car v))))))))

        
(defun search-file ( expr &optional (file $describe_documentation) &aux (ch 0) cha leng)
  (with-open-file (st file)
    (setq leng   (send st :length))
    (sloop while ch
          when (eql  (setq ch(send st :tyi)) *doc-start*)
          do (setf (fill-pointer *word* )0)
          (with-output-to-string
            (strin *word* )
            (sloop  until (zl-MEMBER (setq cha (send st :tyi))
                                   '(#\space #\return #\newline nil))
                   do
                  (send strin :tyo cha)))
          and
          when(string-search expr *word*)
          do
          (sloop while cha until (eql (setq cha (send st :tyi)) *doc-start*)
                do
                (send *standard-output* :tyo cha)))))

#+cl
(defun get-next-keyword (stream &aux cha (ch 0))
  (setf (fill-pointer *word*) 0)
  (sloop while ch when 
        (eql (setq ch (tyi stream )) *doc-start*)
            do 
            (with-output-to-string
              (strin *word* )
              (sloop until (zl-MEMBER (setq cha (tyi stream))
                                     '(#\space #\return #\newline))
                    do
                    (tyo cha strin)
                    ))
            (return (values *word*))))
#-cl
(defun get-next-keyword (stream &aux cha (ch 0))
  (setf (fill-pointer *word*) 0)
  (sloop while ch when 
        (eql (setq ch (send stream :tyi)) *doc-start* )
        do 
        (with-output-to-string
          (strin *word* )
          (sloop until (zl-MEMBER (setq cha (send st :tyi))
                              '(#\space #\return #\newline))
                do
                (send strin :tyo cha)))
         (return (values *word*))))

)



(defun mread-noprompt (&rest read-args)
  (let ((*mread-prompt* ""))
    (declare (special *mread-prompt*))
    (or read-args (setq read-args (list *query-io*)))
  (caddr (apply #'mread read-args))))


;;;some functions for converting from the DOE style documentation file
;;;to the type we use. DO-IT is the function that does it.
;;in our documentation files the key always follows a a \n *doc-start*


;(defun my-alphabetp (ch)
;  (or (maxima:alphabetp ch)
;      (memq ch '(#/")
;           )))
;(defun read-from-stream-for-fix (stream to-string prev-name left-over &aux (from-file t) in-white info (spaces 0) tem eof ch)
;  (setf (fill-pointer to-string) 0)
;  (cond (prev-name
;        (with-output-to-string (str to-string)
;          (cond ((and left-over (> (length (the string  left-over)) 0)
;                      (eql (aref left-over 0) #/())
;                    (format str "~%~%&~s" prev-name))
;                (t   (format str "~%~%&~s " prev-name))))))
;  (cond (left-over
;        (with-output-to-string (str to-string)
;          (format str "~A" left-over))))
;;  (cond ((setq tem (string-search "                               " to-string))
;;       (show to-string)
;;        (setq spaces 20)(setq from-file nil)(setf (fill-pointer to-string) tem)))
;  (sloop named sue
;       when (> spaces 40)
;         do  (setq in-white (fill-pointer to-string))
;             (cond (from-file
;                    (sloop with past-space
;                          while (setq ch (send stream :tyi))
;                          do (vector-push-extend  ch to-string)
;                          until (memq ch  '(#\linefeed #\newline))
;                          when (not (eql ch #\space))
;                            do(setq past-space t)
;                          until (and past-space (eql ch #\space))))
;                   (t (setq from-file t)))
;             (multiple-value-bind (answ left-over end) (check-for-end to-string in-white)
;               (cond (answ (setf (fill-pointer to-string) end)
;                           (return-from sue  (values answ left-over)))))
;       while (setq ch (send stream :tyi))
;       do (vector-push-extend  ch to-string)
;       when (eql ch #\space)
;         do
;           (incf spaces)
;       else do (setq spaces 0)))
;
;;;for copying documentation file
;
;(defun do-it (strin in-file out-file &aux next-name left-over )
;  (with-open-file
;    (st  in-file
;;        (st  "isaac:>wfs>doc.tem")
;    (with-open-file (st1 out-file '(:out))
;    (sloop ;for i below n
;         do
;      (multiple-value-setq (next-name left-over)
;         (read-from-stream-for-fix st strin next-name left-over ))
;         while next-name do
;;      (format t "~%~S" next-name)
;      (format st1 "~A" strin)
;             ))))
;;(do-it *strin*)
;(defvar *strin* (make-array 100 :type 'art-string :fill-pointer 0))
;
;(defun not-white-space-p (n) (cond ((not (memq n '(#\space #\newline ))) n)))
;(defun advance-over-white-space (string start &optional reversep &aux ch )
;  (cond (reversep (sloop for i downfrom start to 0
;                               until (setq ch (not-white-space-p (aref string i)))
;       finally (return (and ch (add1 i)))))
;       (t (sloop for  i from start below (length (the string  string))
;       until (setq ch (not-white-space-p (aref string i)))
;       finally (return (and ch i))))))
;(defun read-atom-from-string (string start)
;  (declare (values contents end-char-position))
;  (condition-case (condit)
;      (progn (read-from-string string nil start))
;      (sys:read-package-not-found nil)))
;


;; Some list creation utilities.


(defmacro $create_list(form &rest l)
  `(create-list2 ',form ',l))

(defun create-list2 (form l)
  (cons '(mlist) (apply 'create-list1 form l)))

(defun create-list1(form &rest l &aux lis var1 top)
  (cond ((null l)(list (meval* form)))
        (t
         (setq var1 (car l)
               lis (second l)
               l (cddr l))
         (or (symbolp var1) (merror "~a not a symbol" var1))
         (setq lis (meval* lis))
         (progv (list var1)
                (list nil)
                (cond ((and (numberp lis)
                            (progn
                              (setq top (car l) l (cdr l))
                              (setq top (meval* top))
                              (numberp top)))
                       (sloop for i from lis to top
                              nodeclare t
                              do (set var1 i)
                              append
                              (apply 'create-list1
                                     form l)))
                      (($listp lis)
                       (sloop for v in (cdr lis)
                              do (set var1 v)
                              append
                              (apply 'create-list1
                                     form l)
                              ))
                      (T (merror "BAD ARG")))))))