share/misc/dump.lisp

   1 ; compile in OLDIO (otherwise DUMPP won't be able to be fasloaded into QA).
   2 (declare (special $arrays))
   3
   4 (cond ((status featur newio)
   5        (defprop dumparrays (dumpar fasl dsk share) autoload)
   6        (defprop loadarrays (dumpar fasl dsk share) autoload)))
   7
   8 (defun $dumparrays fexpr (l)
   9        (prog (filespec ary)
  10              (cond (($listp (car l))
  11                     (setq filespec (filestrip (cdar l)))
  12                     (apply 'crunit (cddr filespec))
  13                     (setq l (cdr l)))
  14                    (t (setq filespec (filestrip nil))))
  15              (cond ((null l) (error "must have something to save")))
  16              (setq ary (gensym))
  17              (setf (symbol-array ary) (make-array (* 6. (length l)) :initial-element 0))
  18              (do ((l1 l (cdr l1))
  19                   (l2)
  20                   (i 0)
  21                   (aryv (get ary 'array)))
  22                  ((null l1))
  23                  (setq l2 (car l1))
  24                  (cond ((not (and (get l2 'array)
  25                                   (member (car (setq l2 (arraydims l2)))
  26                                         '(fixnum flonum) :test #'eq)))
  27                         (displa l2)
  28                         (error " not a number array")))
  29                  (do ((l3 (cdr l2) (cdr l3))) ((null l3))
  30                      (setf (aref aryv i) (car l3))
  31                      (incf i))
  32                  (incf i))
  33              (dumparrays (cons ary l) filespec))
  34        (cons '(mlist) (cons (append '((mlist)) (status crfile) (status crunit)) l)))
  35
  36 (defun $loadarrays fexpr (l)
  37        (cond ((> (length l) 4.) (error "too many args to loadplots")))
  38        (setq l (filestrip l))
  39        (apply 'crunit (cddr l))
  40        (cond ((null (apply 'uprobe l)) (princ l) (error '| file not found|)))
  41        (cond ((null (prog1
  42                         (or (status featur newio) (apply 'dumpp l))
  43                       (setq l (append (status crfile) (status crunit)))))
  44               (princ l) (error " not a file of saved arrays")))
  45        (setq l (loadarrays l))
  46        (do ((aryv (get (caar l) 'array)) (l (cdr l) (cdr l)) (l1) (i 0.))
  47            ((null l) '$done)
  48            (setq l1 (car l))
  49            (cond ((and (get (cadr l1) 'array)
  50                        (eq (car (arraydims (cadr l1)))
  51                            (car (arraydims (car l1)))))
  52                   (fillarray (cadr l1) (car l1)))
  53                  (t (putprop (cadr l1) (get (car l1) 'array) 'array)))
  54            (setq l1 (cadr l1))
  55            (mputprop l1 l1 'array)
  56            (do ((l2 nil))
  57                ((zerop (aref aryv i))
  58                 (setq i (1+ i)))
  59                (setq l2 (cons (aref aryv i) l2)
  60                      i (1+ i)))
  61            (add2lnc l1 $arrays)))
  62
  63 ;; checks to see if file is dumparray'ed by looking at the first word of the file
  64 (lap dumpp fsubr)
  65         (movei t 4)
  66         (pushj p uinita)
  67         (movei a nil)
  68         (*open 0 utin)
  69         (jrst 0 nogo)
  70         (*iot 0 tt)
  71         (camn tt (% -262143.)) ;-1,,1 (works because arrayname fits in one word)
  72         (movei a 't)
  73  nogo   (*close 0)
  74         (jrst 0 intrel)
  75         nil
  76