Attachment #58912 for bug #92644

View | Details | Raw Unified | Return to bug 92644
Collapse All | Expand All




(eval-when (compile eval load)
(defun sharp-u-reader (stream subchar arg)
  (declare (ignore subchar arg))
  (let ((tem (make-array 10 :element-type 'character
			 :fill-pointer 0 :adjustable t)))
    (unless (eql (read-char stream) #\")
      (error "sharp-u-reader reader needs a \"right after it"))

					    (#\r . #\return))))
			   ch))))
       (vector-push-extend ch tem)))
    (coerce tem '(simple-array character (*)))))

(set-dispatch-macro-character #\# #\u 'sharp-u-reader)
)

	(error "illegal file start ~a" start))
      #-gcl
      (let ((tem (make-array (- len start)
			     :element-type 'character)))
	(when (> start 0)
	  (file-position st start))
	(read-sequence tem st :start 0 :end (length tem))

	       ((> extra 0)
		(setq tem 
		      (make-array (+ (length x) extra)
				  :element-type 'character :fill-pointer 0))
		(setq i 0)
		(go AGAIN))
	       (t (setq tem x)))

Lines 1125-1131 Link Here

(-)maxima-5.9.1/src/numerical/f2cl-lib.lisp (-1 / +1 lines)
1125	`',dims	1125	`',dims
1126	`(list ,@dims))))	1126	`(list ,@dims))))
1127	`(let ((,init (make-array ,new-dims	1127	`(let ((,init (make-array ,new-dims
1128	:element-type `(simple-array base-char (,',@len))	1128	:element-type `(simple-array character (,',@len))
1129	:initial-element (make-string ,@len))))	1129	:initial-element (make-string ,@len))))
1130	(dotimes (k (array-total-size ,init))	1130	(dotimes (k (array-total-size ,init))
1131	(setf (aref ,init k)	1131	(setf (aref ,init k)

Lines 10-16 Link Here

(-)maxima-5.9.1/src/numerical/slatec/xercnt.lisp (-1 / +1 lines)
10		10
11	(defun xercnt (librar subrou messg nerr level kontrl)	11	(defun xercnt (librar subrou messg nerr level kontrl)
12	(declare (type f2cl-lib:integer4 kontrl level nerr)	12	(declare (type f2cl-lib:integer4 kontrl level nerr)
13	(type (simple-array base-char (*)) messg subrou librar))	13	(type (simple-array character (*)) messg subrou librar))
14	(prog ()	14	(prog ()
15	(declare)	15	(declare)
16	(go end_label)	16	(go end_label)





(defun xermsg (librar subrou messg nerr level)
  (declare (type f2cl-lib:integer4 level nerr)
           (type (simple-array character (*)) messg subrou librar))
  (prog ((lfirst
          (make-array '(20) :element-type 'character :initial-element #\Space))
         (temp
          (make-array '(72) :element-type 'character :initial-element #\Space))
         (xlibr
          (make-array '(8) :element-type 'character :initial-element #\Space))
         (xsubr
          (make-array '(8) :element-type 'character :initial-element #\Space))
         (ltemp 0) (mkntrl 0) (llevel 0) (lerr 0) (kount 0) (i 0) (kdummy 0)
         (f2cl-lib:f2cl-// 0.0f0) (maxmes 0) (lkntrl 0))
    (declare (type single-float f2cl-lib:f2cl-//)
             (type f2cl-lib:integer4 lkntrl maxmes kdummy i kount lerr llevel
              mkntrl ltemp)
             (type (simple-array character (8)) xsubr xlibr)
             (type (simple-array character (72)) temp)
             (type (simple-array character (20)) lfirst))
    (setf lkntrl (j4save 2 0 f2cl-lib:%false%))
    (setf maxmes (j4save 4 0 f2cl-lib:%false%))
    (cond






(let* ((newlin "$$"))
  (declare (type (simple-array character (2)) newlin))
  (defun xerprn (prefix npref messg nwrap)
    (declare (type f2cl-lib:integer4 nwrap npref)
             (type (simple-array character (*)) messg prefix))
    (prog ((iu (make-array 5 :element-type 'f2cl-lib:integer4)) (nunit 0)
           (cbuff
            (make-array '(148)
                        :element-type
                        'character
                        :initial-element
                        #\Space))
           (idelta 0) (lpiece 0) (nextc 0) (lenmsg 0) (lwrap 0) (lpref 0) (i 0)

      (declare (type (simple-array f2cl-lib:integer4 (5)) iu)
               (type f2cl-lib:integer4 n i lpref lwrap lenmsg nextc lpiece
                idelta nunit)
               (type (simple-array character (148)) cbuff))
      (multiple-value-bind
          (var-0 var-1)
          (xgetua iu nunit)




        (nmsg 0))
    (declare (type f2cl-lib:integer4 nmsg kountx)
             (type (simple-array f2cl-lib:integer4 (*)) kount levtab nertab)
             (type (simple-array (simple-array character (20)) (*)) mestab)
             (type (simple-array (simple-array character (8)) (*)) subtab
              libtab))
    (setq kountx 0)
    (setq nmsg 0)
    (defun xersve (librar subrou messg kflag nerr level icount)
      (declare (type f2cl-lib:integer4 icount level nerr kflag)
               (type (simple-array character (*)) messg subrou librar))
      (prog ((mes
              (make-array '(20)
                          :element-type
                          'character
                          :initial-element
                          #\Space))
             (lib
              (make-array '(8)
                          :element-type
                          'character
                          :initial-element
                          #\Space))
             (sub
              (make-array '(8)
                          :element-type
                          'character
                          :initial-element
                          #\Space))
             (lun (make-array 5 :element-type 'f2cl-lib:integer4)) (i 0)
             (iunit 0) (kunit 0) (nunit 0))
        (declare (type f2cl-lib:integer4 nunit kunit iunit i)
                 (type (simple-array character (20)) mes)
                 (type (simple-array character (8)) lib sub)
                 (type (simple-array f2cl-lib:integer4 (5)) lun))
        (cond
         ((<= kflag 0) (if (= nmsg 0) (go end_label))

Lines 48-54 Link Here

(-)maxima-5.9.1/src/server.lisp (-1 / +1 lines)
48	:element-type (if bin '(unsigned-byte 8) 'character)))	48	:element-type (if bin '(unsigned-byte 8) 'character)))
49	#+gcl (si::socket port :host host)	49	#+gcl (si::socket port :host host)
50	#+lispworks (comm:open-tcp-stream host port :direction :io :element-type	50	#+lispworks (comm:open-tcp-stream host port :direction :io :element-type
51	(if bin 'unsigned-byte 'base-char))	51	(if bin 'unsigned-byte 'character))
52	#-(or allegro clisp cmu sbcl gcl lispworks)	52	#-(or allegro clisp cmu sbcl gcl lispworks)
53	(error 'not-implemented :proc (list 'open-socket host port bin))))	53	(error 'not-implemented :proc (list 'open-socket host port bin))))
54		54

Return to bug 92644

Lines 118-124 Link Here

(-)maxima-5.9.1/src/cl-info.lisp (-4 / +4 lines)
118	(eval-when (compile eval load)	118	(eval-when (compile eval load)
119	(defun sharp-u-reader (stream subchar arg)	119	(defun sharp-u-reader (stream subchar arg)
120	(declare (ignore subchar arg))	120	(declare (ignore subchar arg))
121	(let ((tem (make-array 10 :element-type 'base-char	121	(let ((tem (make-array 10 :element-type 'character
122	:fill-pointer 0 :adjustable t)))	122	:fill-pointer 0 :adjustable t)))
123	(unless (eql (read-char stream) #\")	123	(unless (eql (read-char stream) #\")
124	(error "sharp-u-reader reader needs a \"right after it"))	124	(error "sharp-u-reader reader needs a \"right after it"))
Lines 132-138 Link Here
132	(#\r . #\return))))	132	(#\r . #\return))))
133	ch))))	133	ch))))
134	(vector-push-extend ch tem)))	134	(vector-push-extend ch tem)))
135	(coerce tem '(simple-array base-char (*)))))	135	(coerce tem '(simple-array character (*)))))
136		136
137	(set-dispatch-macro-character #\# #\u 'sharp-u-reader)	137	(set-dispatch-macro-character #\# #\u 'sharp-u-reader)
138	)	138	)
Lines 153-159 Link Here
153	(error "illegal file start ~a" start))	153	(error "illegal file start ~a" start))
154	#-gcl	154	#-gcl
155	(let ((tem (make-array (- len start)	155	(let ((tem (make-array (- len start)
156	:element-type 'base-char)))	156	:element-type 'character)))
157	(when (> start 0)	157	(when (> start 0)
158	(file-position st start))	158	(file-position st start))
159	(read-sequence tem st :start 0 :end (length tem))	159	(read-sequence tem st :start 0 :end (length tem))
Lines 249-255 Link Here
249	((> extra 0)	249	((> extra 0)
250	(setq tem	250	(setq tem
251	(make-array (+ (length x) extra)	251	(make-array (+ (length x) extra)
252	:element-type 'base-char :fill-pointer 0))	252	:element-type 'character :fill-pointer 0))
253	(setq i 0)	253	(setq i 0)
254	(go AGAIN))	254	(go AGAIN))
255	(t (setq tem x)))	255	(t (setq tem x)))

Lines 10-32 Link Here

(-)maxima-5.9.1/src/numerical/slatec/xermsg.lisp (-8 / +8 lines)
10		10
11	(defun xermsg (librar subrou messg nerr level)	11	(defun xermsg (librar subrou messg nerr level)
12	(declare (type f2cl-lib:integer4 level nerr)	12	(declare (type f2cl-lib:integer4 level nerr)
13	(type (simple-array base-char (*)) messg subrou librar))	13	(type (simple-array character (*)) messg subrou librar))
14	(prog ((lfirst	14	(prog ((lfirst
15	(make-array '(20) :element-type 'base-char :initial-element #\Space))	15	(make-array '(20) :element-type 'character :initial-element #\Space))
16	(temp	16	(temp
17	(make-array '(72) :element-type 'base-char :initial-element #\Space))	17	(make-array '(72) :element-type 'character :initial-element #\Space))
18	(xlibr	18	(xlibr
19	(make-array '(8) :element-type 'base-char :initial-element #\Space))	19	(make-array '(8) :element-type 'character :initial-element #\Space))
20	(xsubr	20	(xsubr
21	(make-array '(8) :element-type 'base-char :initial-element #\Space))	21	(make-array '(8) :element-type 'character :initial-element #\Space))
22	(ltemp 0) (mkntrl 0) (llevel 0) (lerr 0) (kount 0) (i 0) (kdummy 0)	22	(ltemp 0) (mkntrl 0) (llevel 0) (lerr 0) (kount 0) (i 0) (kdummy 0)
23	(f2cl-lib:f2cl-// 0.0f0) (maxmes 0) (lkntrl 0))	23	(f2cl-lib:f2cl-// 0.0f0) (maxmes 0) (lkntrl 0))
24	(declare (type single-float f2cl-lib:f2cl-//)	24	(declare (type single-float f2cl-lib:f2cl-//)
25	(type f2cl-lib:integer4 lkntrl maxmes kdummy i kount lerr llevel	25	(type f2cl-lib:integer4 lkntrl maxmes kdummy i kount lerr llevel
26	mkntrl ltemp)	26	mkntrl ltemp)
27	(type (simple-array base-char (8)) xsubr xlibr)	27	(type (simple-array character (8)) xsubr xlibr)
28	(type (simple-array base-char (72)) temp)	28	(type (simple-array character (72)) temp)
29	(type (simple-array base-char (20)) lfirst))	29	(type (simple-array character (20)) lfirst))
30	(setf lkntrl (j4save 2 0 f2cl-lib:%false%))	30	(setf lkntrl (j4save 2 0 f2cl-lib:%false%))
31	(setf maxmes (j4save 4 0 f2cl-lib:%false%))	31	(setf maxmes (j4save 4 0 f2cl-lib:%false%))
32	(cond	32	(cond

Lines 9-23 Link Here

(-)maxima-5.9.1/src/numerical/slatec/xerprn.lisp (-4 / +4 lines)
9		9
10		10
11	(let* ((newlin "$$"))	11	(let* ((newlin "$$"))
12	(declare (type (simple-array base-char (2)) newlin))	12	(declare (type (simple-array character (2)) newlin))
13	(defun xerprn (prefix npref messg nwrap)	13	(defun xerprn (prefix npref messg nwrap)
14	(declare (type f2cl-lib:integer4 nwrap npref)	14	(declare (type f2cl-lib:integer4 nwrap npref)
15	(type (simple-array base-char (*)) messg prefix))	15	(type (simple-array character (*)) messg prefix))
16	(prog ((iu (make-array 5 :element-type 'f2cl-lib:integer4)) (nunit 0)	16	(prog ((iu (make-array 5 :element-type 'f2cl-lib:integer4)) (nunit 0)
17	(cbuff	17	(cbuff
18	(make-array '(148)	18	(make-array '(148)
19	:element-type	19	:element-type
20	'base-char	20	'character
21	:initial-element	21	:initial-element
22	#\Space))	22	#\Space))
23	(idelta 0) (lpiece 0) (nextc 0) (lenmsg 0) (lwrap 0) (lpref 0) (i 0)	23	(idelta 0) (lpiece 0) (nextc 0) (lenmsg 0) (lwrap 0) (lpref 0) (i 0)
Lines 25-31 Link Here
25	(declare (type (simple-array f2cl-lib:integer4 (5)) iu)	25	(declare (type (simple-array f2cl-lib:integer4 (5)) iu)
26	(type f2cl-lib:integer4 n i lpref lwrap lenmsg nextc lpiece	26	(type f2cl-lib:integer4 n i lpref lwrap lenmsg nextc lpiece
27	idelta nunit)	27	idelta nunit)
28	(type (simple-array base-char (148)) cbuff))	28	(type (simple-array character (148)) cbuff))
29	(multiple-value-bind	29	(multiple-value-bind
30	(var-0 var-1)	30	(var-0 var-1)
31	(xgetua iu nunit)	31	(xgetua iu nunit)

Lines 20-56 Link Here

(-)maxima-5.9.1/src/numerical/slatec/xersve.lisp (-8 / +8 lines)
20	(nmsg 0))	20	(nmsg 0))
21	(declare (type f2cl-lib:integer4 nmsg kountx)	21	(declare (type f2cl-lib:integer4 nmsg kountx)
22	(type (simple-array f2cl-lib:integer4 (*)) kount levtab nertab)	22	(type (simple-array f2cl-lib:integer4 (*)) kount levtab nertab)
23	(type (simple-array (simple-array base-char (20)) (*)) mestab)	23	(type (simple-array (simple-array character (20)) (*)) mestab)
24	(type (simple-array (simple-array base-char (8)) (*)) subtab	24	(type (simple-array (simple-array character (8)) (*)) subtab
25	libtab))	25	libtab))
26	(setq kountx 0)	26	(setq kountx 0)
27	(setq nmsg 0)	27	(setq nmsg 0)
28	(defun xersve (librar subrou messg kflag nerr level icount)	28	(defun xersve (librar subrou messg kflag nerr level icount)
29	(declare (type f2cl-lib:integer4 icount level nerr kflag)	29	(declare (type f2cl-lib:integer4 icount level nerr kflag)
30	(type (simple-array base-char (*)) messg subrou librar))	30	(type (simple-array character (*)) messg subrou librar))
31	(prog ((mes	31	(prog ((mes
32	(make-array '(20)	32	(make-array '(20)
33	:element-type	33	:element-type
34	'base-char	34	'character
35	:initial-element	35	:initial-element
36	#\Space))	36	#\Space))
37	(lib	37	(lib
38	(make-array '(8)	38	(make-array '(8)
39	:element-type	39	:element-type
40	'base-char	40	'character
41	:initial-element	41	:initial-element
42	#\Space))	42	#\Space))
43	(sub	43	(sub
44	(make-array '(8)	44	(make-array '(8)
45	:element-type	45	:element-type
46	'base-char	46	'character
47	:initial-element	47	:initial-element
48	#\Space))	48	#\Space))
49	(lun (make-array 5 :element-type 'f2cl-lib:integer4)) (i 0)	49	(lun (make-array 5 :element-type 'f2cl-lib:integer4)) (i 0)
50	(iunit 0) (kunit 0) (nunit 0))	50	(iunit 0) (kunit 0) (nunit 0))
51	(declare (type f2cl-lib:integer4 nunit kunit iunit i)	51	(declare (type f2cl-lib:integer4 nunit kunit iunit i)
52	(type (simple-array base-char (20)) mes)	52	(type (simple-array character (20)) mes)
53	(type (simple-array base-char (8)) lib sub)	53	(type (simple-array character (8)) lib sub)
54	(type (simple-array f2cl-lib:integer4 (5)) lun))	54	(type (simple-array f2cl-lib:integer4 (5)) lun))
55	(cond	55	(cond
56	((<= kflag 0) (if (= nmsg 0) (go end_label))	56	((<= kflag 0) (if (= nmsg 0) (go end_label))