[albert-cvs] CVS: albert/spres tools.lisp,1.17,1.18

[Stig E S. <st...@us...>]

Update of /cvsroot/albert/albert/spres
In directory sc8-pr-cvs1:/tmp/cvs-serv31459/spres

Modified Files:
	tools.lisp 
Log Message:
moved much code to files.lisp, also tweaked make-valid-entity somehwat

Index: tools.lisp
===================================================================
RCS file: /cvsroot/albert/albert/spres/tools.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -C2 -d -r1.17 -r1.18
*** tools.lisp	27 Oct 2003 01:04:06 -0000	1.17
--- tools.lisp	27 Oct 2003 16:42:43 -0000	1.18
***************
*** 15,81 ****
  (in-package :spres-impl)
  
- (defun tl-find-out-dir (format)
-   "Returns a pathname for the out-dir."
-   
-   ;;Ugly imperative style.
-   ;;(warn ">> Ensure out-dir for ~s -> ~s." format (tl-get-outdir-pref format))
-   ;;(warn "Pref is ~s" (albert-setting '("system" "directory")))
-   (let ((sys-dir (albert-setting '("system" "directory")))
- 	(pref-dir (tl-get-outdir-pref format)))
- 
-     (when (albert-setting '("albert" "presentation" "to-current-dir"))
-       (setf sys-dir cl:*default-pathname-defaults*))
-     
-     (cond ((pathnamep pref-dir) nil)
- 	  ((stringp pref-dir)
- 	   (setf pref-dir (pathname (ensure-dir-name pref-dir))))
- 	  (t
- 	   (albert-warn "spres> settings dir for ~s is ~s, not string/pathname." format pref-dir)
- 	   (return-from tl-find-out-dir nil)))
-     
-     (cond ((pathnamep sys-dir) nil)
- 	  ((stringp sys-dir)
- 	   (setf sys-dir (ensure-dir-name (pathname sys-dir))))
- 	  (t (setf sys-dir cl:*default-pathname-defaults*)))
- 
-     ;;(warn "Returning ~s" (merge-pathnames pref-dir sys-dir))
-     
-     (merge-pathnames pref-dir sys-dir)))
- #||    
-     
- 	   (warn "Pref is ~s" (merge-pathnames (pathname  (albert-setting '("system" "directory")))
-   (let ((out-dir (ensure-dir-name (tl-get-outdir-pref format))))
-     (pathname (ensure-dir-name out-dir))))
- ||#
- 
- (defun tl-get-outdir-pref (format)
-   "Returns the actual outdir-preference in the given output-preference.
- Returns the actual pref and not a list. Returns NIL on failure."
-   (let ((retval nil))
-     
-     (when format
-       (when (typep format 'spres-format)
- 	(setf format (format.name format)))
-       
-       (cond ((stringp format)
- 	     (when-bind (val (albert-setting (list "albert" format "output-dir")))
- 	       (cond ((stringp val)
- 		      (setf retval val))
- 		     (t
- 		      (warn "Don't know how to handle outdir value ~s for format ~s" val format)))))
- 	  (t
- 	   (warn "Unable to handle format to get outdir: ~s" format))))
-     
-     (unless retval
-       (when-bind (val (albert-setting '("albert" "presentation" "output-dir")))
- 	(cond ((stringp val)
- 	       (setf retval val))
- 	      (t
- 	       (warn "Don't know how to handle outdir value ~s" val)))))
-     
-     (unless retval
-       (setf retval "dumps/"))
- 
-     retval))
    
  
--- 15,18 ----
***************
*** 142,292 ****
    
  
- (defun permute-fname-and-add (f-obj table)
-   "permutes the fname with counter till it is addable
- to the given table."
-   (let ((key (file-info-to-fname f-obj)))
-     (multiple-value-bind (obj found-p)
- 	(gethash key table)
-       (declare (ignore obj))
-       (cond (found-p
- 	     (incf (file-info-counter f-obj))
- 	     (permute-fname-and-add f-obj table))
- 	    (t
- 	     (setf (gethash key table) f-obj))))))
- 
- 
- (defun search-for-file-names (obj-list table)
-   "goes recursively through the object list and adds any 
- filenames to the table"
- 
-     (dolist (x obj-list)
-       ;; hackish
-       (let ((?outdir (if (typep x '(or sdoc-package sdoc-module))
- 			 (pathname (strcat (namestring ?outdir)
- 					   (get-object-name x) "/"))
- 			 ?outdir)))
- 	
- ;;	(when (typep x 'sdoc-package)
- ;;	  (warn "dir is ~a" ?outdir)
- ;;	  )
- 	
- 	(unless (is-empty? x)
- 	  
- 	  (when (should-have-individual-file-p x nil)
- 	    (let ((wanted-file (get-suggested-file-name x nil)))
- 	      (when wanted-file
- 		(let ((key (file-info-to-fname wanted-file)))
- 		  (multiple-value-bind (obj found-p)
- 		      (gethash key table)
- 		    (declare (ignore obj))
- 		    (cond (found-p
- 			   (permute-fname-and-add wanted-file table))
- 			  (t
- 			   (setf (gethash key table) wanted-file))))))))
- 
- 	  (when (typep x '(or sdoc-package sdoc-module sdoc-class))
- 	    (calculate-file-list x table))))))
- 
- 
- (defmethod calculate-file-list ((object sdoc-toplevel) table)
- 
-   (unless table
-     (setq table (make-hash-table :test #'equal)))
- 
-   (let ((?outdir ""))
-     (search-for-file-names (sdoc-toplevel.content object) table))
- 
-   (let ((ret-table (make-hash-table :test #'equal)))
-     (loop for v being the hash-values of table
- 	  do
- 	  (setf (gethash (file-info-id v) ret-table) v))
-     
-     ret-table))
- 
- (def-or-method calculate-file-list ((object (or sdoc-package sdoc-class sdoc-module)) table)
- 
-   (let ((content-list (slot-value object 'content)))
-   
-     (search-for-file-names content-list table)
- 
-     #||
-     (when (typep object 'sdoc-package)
- 
-       (when (find-if #'(lambda (x) (typep x 'sdoc-class)) content-list)
- 	(let ((id (strcat "package_" (get-object-name object) "_classlist")))
- 	  (setf (gethash id table) (make-file-info :id id
- 						   :dir ?outdir 
- 						   :fname (make-valid-entity id)
- 						   :counter 0))))
-       
-       (when (find-if #'is-generic-fun? content-list)
- 	(let ((id (strcat "package_" (get-object-name object) "_genfunlist")))
- 	  (setf (gethash id table) (make-file-info :id id
- 						   :dir ?outdir 
- 						   :fname (make-valid-entity id)
- 						   :counter 0)))))
-     ||#
-     ))
-   
-   
- 
- (defmethod get-suggested-file-name ((object sdoc-package) context)
-   (declare (ignore context))
-   (make-file-info :id (get-object-id object)
- 		  :dir ?outdir
- 		  :fname "_package"
- 		  :counter 0))
- 
- (defmethod get-suggested-file-name ((object sdoc-module) context)
-   (declare (ignore context))
-   (make-file-info :id (get-object-id object)
- 		  :dir ?outdir
- 		  :fname "_module"
- 		  :counter 0))
- 
- 
- (defmethod get-suggested-file-name ((object sdoc-class) context)
-   (declare (ignore context))
-   (make-file-info :id (get-object-id object) 
- 		  :dir ?outdir 
- 		  :fname (make-valid-entity (get-object-name object))
- 		  :counter 0))
- 
- (defmethod get-suggested-file-name ((object sdoc-method) context)
-   (declare (ignore context))
-   (make-file-info :id (get-object-id object) 
- 		  :dir ?outdir 
- 		  :fname (make-valid-entity (get-object-name object))
- 		  :counter 0))
- 
- 
- 
- (defun file-info-to-fname (f-obj)
-   "Translates the file-info obj into a filename string"
-   (let ((fname (file-info-fname f-obj)))
-     (when (> (file-info-counter f-obj) 0)
-       (setq fname (format nil "~a-~a" fname (file-info-counter f-obj))))
-     (strcat (namestring (file-info-dir f-obj)) fname)))
- 
- (defun tl-ensure-file-dirs (file-table base-dir)
-   "given a file-table and a pathname base-dir.  Calls
- sds-global:make-sure-dirs-exist."
-       ;; ensure directories in place
-     (let ((done-dirs nil))
-       (loop for val being the hash-values of file-table
- 	    for dir = (file-info-dir val)
- 	    do
- 	    (unless (find dir done-dirs :test #'equal)
- ;;	      (warn "Merging ~s and ~s -> ~s,~s" ?outdir dir
- ;;		    (merge-pathnames dir ?outdir)
- ;;		    (merge-pathnames ?outdir dir)
- ;;		    )
- 	      (make-sure-dirs-exist
- 	       (tl-merge-two-paths dir base-dir))
- 	      (push dir done-dirs)))))
  
  
  		   
! (defun make-valid-entity (word)
    "translates the word into something eatable as entity and id in
  sml and label in tex.  It is returned as a _string_"
--- 79,86 ----
    
  
  
  
  		   
! (defun make-valid-entity (word &key (allow nil))
    "translates the word into something eatable as entity and id in
  sml and label in tex.  It is returned as a _string_"
***************
*** 294,330 ****
      (loop for x across word
  	  do
! 	  (if (find x '(#\% #\? #\/ #\* #\& #\! #\*
! 			#\~ #\[ #\] #\+ #\= #\@ #\,
! 			#\( #\) #\# #\< #\> #\Space) :test #'eql)
! 	      (write-string +id-word-delim+ str)
! 	      (write-char x str)))))
! 
! 
! (defun include-file-entity (f-obj)
!   "Returns a string which is a legal file-inclusion
! in xml for the given f-obj"
!   
!   (if (stringp f-obj)
!       (strcat "&file" +id-word-delim+ (make-valid-entity f-obj) ";")
!       (strcat "&file" +id-word-delim+ (make-valid-entity (file-info-to-fname f-obj)) ";")))
!   
! 
! 
! (def-or-method should-have-individual-file-p ((object (or sdoc-package
! 							  sdoc-class
! 							  sdoc-module)) context)
! 
!   ;; to avoid silly warning.. any compiler should wipe it
!   (when (and nil object context))
!     
!   t)
! 
! (defmethod should-have-individual-file-p ((object sdoc-method) context)
! 
!   (when (is-generic-fun? object)
!     (when (>= (length (sdoc-method.content object))
! 	      (setting-or-default '("albert" "presentation" "gf" "separatepage") 2))
!       ;;(warn "File for ~s" object)
!       t)))
  
  
--- 88,99 ----
      (loop for x across word
  	  do
! 	  (cond ((and (consp allow) (find x allow))
! 		 (write-char x str))
! 		((find x '(#\% #\? #\/ #\* #\& #\! #\*
! 			   #\~ #\[ #\] #\+ #\= #\@ #\,
! 			   #\( #\) #\# #\< #\> #\Space) :test #'eql)
! 		 (write-string +id-word-delim+ str))
! 		(t
! 		 (write-char x str))))))
  
  
***************
*** 370,463 ****
  			       "type"))))
  
- (defun tl-make-new-obj-document (obj &optional old-doc)
-   "presents an independent file.."
-   (let ((f-obj (gethash (get-object-id obj) ?file-table)))
- 
- ;;    (warn "Filename ~a -> [~a] ~a" f-obj
- ;;	  ?outdir (file-info-to-fname f-obj))
- 
-     ;; insert into the old-document an insert
-     (when old-doc
-       (put old-doc (include-file-entity f-obj) (eol)))
-     
-     ;; here is a directory-making bug
-     (make-document ?outdir
- 		   (file-info-to-fname f-obj) 
- 		   ?format
- 		   ?language)))
- 
- (defun tl-make-new-document (filename old-doc)
-   
-   (when old-doc
-     (put old-doc (include-file-entity filename) (eol)))
- 
-   (make-document ?outdir
- 		 (if (stringp filename)
- 		     (make-valid-entity filename)
- 		     (file-info-to-fname filename))
- 		 ?format
- 		 ?language))
- 
- 
- (defun tl-get-ok-obj-document (obj old-doc)
-   "Returns a new document if the OBJ requires an
- idividual file, otherwise returns the given document."
-   
- ;;  (warn "Getting document from ~a ~a -> ~a" obj old-doc
- ;;	(should-have-individual-file-p obj nil))
- 
-   (if (should-have-individual-file-p obj nil)
-       (tl-make-new-obj-document obj old-doc)
- 
-       old-doc))
- 
- 
- (defun tl-possible-close-document (obj doc)
-   "If the object OBJ requires it's own file, close this file,
- assuming it was opened by WITH-OK-DOCUMENT and therefore is
- safe.  The closed document is also presented."
-   
-   (when (should-have-individual-file-p obj nil)
- ;;    (warn "closing/presenting ~a document ~a" obj doc)
-     (present-document doc)))
- 
- (defmacro with-ok-obj-document (the-info &body the-body)
- 
-   (unless (and (consp the-info) (= 3 (length the-info)))
-     (error "WITH-OK-DOCUMENT 1st argument should be (DOC-VAR OBJ OLD-DOC)"))
-   
-   (let ((gs (gensym))
- 	(old-doc (third the-info))
- 	(the-obj (second the-info))
- 	(doc-name (first the-info)))
-     
-     `(let ((,gs ,old-doc))
-       (unwind-protect
- 	   (let ((,doc-name (tl-get-ok-obj-document ,the-obj ,old-doc)))
- 	     (unwind-protect
- 		  ,@the-body
- 	       (tl-possible-close-document ,the-obj ,doc-name)))
- 	(setf ,old-doc ,gs)))
-     ))
- 
- (defmacro with-ok-document (the-info &body the-body)
- 
- ;;  (unless (and (consp the-info) (= 3 (length the-info)))
- ;;    (error "WITH-OK-DOCUMENT 1st argument should be (DOC-VAR OBJ OLD-DOC)"))
-   
-   (let ((gs (gensym))
- 	(old-doc (third the-info))
- 	(fname (second the-info))
- 	(doc-name (first the-info))
- 	)
-     
-     `(let ((,gs ,old-doc))
-       (unwind-protect
- 	   (let ((,doc-name (tl-make-new-document ,fname ,old-doc)))
- 	     (unwind-protect
- 		  ,@the-body
- 	       (present-document ,doc-name)))
- 	(setf ,old-doc ,gs)))
-     ))
  
  (defun %strip-setf (x)
--- 139,142 ----
***************
*** 551,557 ****
  	t)))
  
- (defgeneric mergable-objs? (doc first-obj second-obj)
-   (:documentation "Decides whether two objects may be
- merged for presentation."))
  
  (defmethod mergable-objs? (doc first-obj second-obj)
--- 230,233 ----
***************
*** 560,565 ****
  
  
- 
- 
  (defun tl-clean-for-leading-stars (str)
    "makes sure comments look sane when output.  Contains
--- 236,239 ----
***************
*** 655,668 ****
      (tl-print-tree str tree)))
  
- #||
- (defun tl-make-anchor (&rest args)
-   "Returns an anchor."
-   (with-output-to-string (s)
-     (write-string "<anchor id=\"" s)
-     (dolist (i args)
-       (when i
- 	(format s "~a" i)))
-     (write-string "\"/>" s)))
- ||#
  
  (defun tl-merge-list (doc the-list)
--- 329,332 ----
***************
*** 838,843 ****
  	    (nreverse filtered))))
  
- (defstruct idx-entry
-   name obj parent)
    
  
--- 502,505 ----