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