← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/numerical/slatec/xermsg.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/numerical/slatec/xermsg.lisp
1
 
;;; Compiled by f2cl version 2.0 beta 2002-05-06
 
1
;;; Compiled by f2cl version 2.0 beta Date: 2006/01/31 15:11:05 
 
2
;;; Using Lisp CMU Common Lisp Snapshot 2006-01 (19C)
2
3
;;; 
3
4
;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
4
5
;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
5
6
;;;           (:array-slicing nil) (:declare-common nil)
6
7
;;;           (:float-format double-float))
7
8
 
8
 
(in-package "SLATEC")
 
9
(in-package :slatec)
9
10
 
10
11
 
11
12
(defun xermsg (librar subrou messg nerr level)
12
13
  (declare (type f2cl-lib:integer4 level nerr)
13
 
           (type (simple-array base-char (*)) messg subrou librar))
 
14
           (type (simple-array character (*)) messg subrou librar))
14
15
  (prog ((lfirst
15
 
          (make-array '(20) :element-type 'base-char :initial-element #\Space))
 
16
          (make-array '(20) :element-type 'character :initial-element #\ ))
16
17
         (temp
17
 
          (make-array '(72) :element-type 'base-char :initial-element #\Space))
 
18
          (make-array '(72) :element-type 'character :initial-element #\ ))
18
19
         (xlibr
19
 
          (make-array '(8) :element-type 'base-char :initial-element #\Space))
 
20
          (make-array '(8) :element-type 'character :initial-element #\ ))
20
21
         (xsubr
21
 
          (make-array '(8) :element-type 'base-char :initial-element #\Space))
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))
24
 
    (declare (type single-float f2cl-lib:f2cl-//)
 
22
          (make-array '(8) :element-type 'character :initial-element #\ ))
 
23
         (ltemp 0) (abs$ 0.0f0) (mkntrl 0) (llevel 0) (lerr 0) (kount 0) (i 0)
 
24
         (kdummy 0) (f2cl-lib:f2cl-// 0.0f0) (maxmes 0) (lkntrl 0))
 
25
    (declare (type single-float f2cl-lib:f2cl-// abs$)
25
26
             (type f2cl-lib:integer4 lkntrl maxmes kdummy i kount lerr llevel
26
 
              mkntrl ltemp)
27
 
             (type (simple-array base-char (8)) xsubr xlibr)
28
 
             (type (simple-array base-char (72)) temp)
29
 
             (type (simple-array base-char (20)) lfirst))
 
27
                                     mkntrl ltemp)
 
28
             (type (simple-array character (8)) xsubr xlibr)
 
29
             (type (simple-array character (72)) temp)
 
30
             (type (simple-array character (20)) lfirst))
30
31
    (setf lkntrl (j4save 2 0 f2cl-lib:%false%))
31
32
    (setf maxmes (j4save 4 0 f2cl-lib:%false%))
32
33
    (cond
33
 
     ((or (< nerr (f2cl-lib:int-sub 9999999))
34
 
          (> nerr 99999999)
35
 
          (= nerr 0)
36
 
          (< level (f2cl-lib:int-sub 1))
37
 
          (> level 2))
38
 
      (xerprn " ***" -1
39
 
       (f2cl-lib:f2cl-//
40
 
        (f2cl-lib:f2cl-// "FATAL ERROR IN...$$ "
41
 
                          "XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ ")
42
 
        "JOB ABORT DUE TO FATAL ERROR.")
43
 
       72)
44
 
      (multiple-value-bind
45
 
          (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
46
 
          (xersve " " " " " " 0 0 0 kdummy)
47
 
        (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
48
 
        (setf kdummy var-6))
49
 
      (xerhlt " ***XERMSG -- INVALID INPUT") (go end_label)))
 
34
      ((or (< nerr (f2cl-lib:int-sub 9999999))
 
35
           (> nerr 99999999)
 
36
           (= nerr 0)
 
37
           (< level (f2cl-lib:int-sub 1))
 
38
           (> level 2))
 
39
       (xerprn " ***" -1
 
40
        (f2cl-lib:f2cl-//
 
41
         (f2cl-lib:f2cl-// "FATAL ERROR IN...$$ "
 
42
                           "XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ ")
 
43
         "JOB ABORT DUE TO FATAL ERROR.")
 
44
        72)
 
45
       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
46
           (xersve " " " " " " 0 0 0 kdummy)
 
47
         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
 
48
         (setf kdummy var-6))
 
49
       (xerhlt " ***XERMSG -- INVALID INPUT")
 
50
       (go end_label)))
50
51
    (setf i (j4save 1 nerr f2cl-lib:%true%))
51
 
    (multiple-value-bind
52
 
        (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
52
    (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
53
53
        (xersve librar subrou messg 1 nerr level kount)
54
54
      (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
55
55
      (setf kount var-6))
75
75
             (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 maxmes))))
76
76
     (go label30))
77
77
    (cond
78
 
     ((/= lkntrl 0)
79
 
      (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 21))
80
 
                            "MESSAGE FROM ROUTINE ")
81
 
      (setf i
82
 
              (min (the f2cl-lib:integer4 (f2cl-lib:len subrou))
83
 
                   (the f2cl-lib:integer4 16)))
84
 
      (f2cl-lib:fset-string
85
 
       (f2cl-lib:fref-string temp (22 (f2cl-lib:int-add 21 i)))
86
 
       (f2cl-lib:fref-string subrou (1 i)))
87
 
      (f2cl-lib:fset-string
88
 
       (f2cl-lib:fref-string temp ((+ 22 i) (f2cl-lib:int-add 33 i)))
89
 
       " IN LIBRARY ")
90
 
      (setf ltemp (f2cl-lib:int-add 33 i))
91
 
      (setf i
92
 
              (min (the f2cl-lib:integer4 (f2cl-lib:len librar))
93
 
                   (the f2cl-lib:integer4 16)))
94
 
      (f2cl-lib:fset-string
95
 
       (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp i)))
96
 
       (f2cl-lib:fref-string librar (1 i)))
97
 
      (f2cl-lib:fset-string
98
 
       (f2cl-lib:fref-string temp ((+ ltemp i 1) (f2cl-lib:int-add ltemp i 1)))
99
 
       ".")
100
 
      (setf ltemp (f2cl-lib:int-add ltemp i 1))
101
 
      (xerprn " ***" -1 (f2cl-lib:fref-string temp (1 ltemp)) 72)))
 
78
      ((/= lkntrl 0)
 
79
       (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 21))
 
80
                             "MESSAGE FROM ROUTINE ")
 
81
       (setf i
 
82
               (min (the f2cl-lib:integer4 (f2cl-lib:len subrou))
 
83
                    (the f2cl-lib:integer4 16)))
 
84
       (f2cl-lib:fset-string
 
85
        (f2cl-lib:fref-string temp (22 (f2cl-lib:int-add 21 i)))
 
86
        (f2cl-lib:fref-string subrou (1 i)))
 
87
       (f2cl-lib:fset-string
 
88
        (f2cl-lib:fref-string temp ((+ 22 i) (f2cl-lib:int-add 33 i)))
 
89
        " IN LIBRARY ")
 
90
       (setf ltemp (f2cl-lib:int-add 33 i))
 
91
       (setf i
 
92
               (min (the f2cl-lib:integer4 (f2cl-lib:len librar))
 
93
                    (the f2cl-lib:integer4 16)))
 
94
       (f2cl-lib:fset-string
 
95
        (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp i)))
 
96
        (f2cl-lib:fref-string librar (1 i)))
 
97
       (f2cl-lib:fset-string
 
98
        (f2cl-lib:fref-string temp
 
99
                              ((+ ltemp i 1) (f2cl-lib:int-add ltemp i 1)))
 
100
        ".")
 
101
       (setf ltemp (f2cl-lib:int-add ltemp i 1))
 
102
       (xerprn " ***" -1 (f2cl-lib:fref-string temp (1 ltemp)) 72)))
102
103
    (cond
103
 
     ((> lkntrl 0)
104
 
      (cond
105
 
       ((<= level 0)
106
 
        (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 20))
107
 
                              "INFORMATIVE MESSAGE,")
108
 
        (setf ltemp 20))
109
 
       ((= level 1)
110
 
        (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 30))
111
 
                              "POTENTIALLY RECOVERABLE ERROR,")
112
 
        (setf ltemp 30))
113
 
       (t
114
 
        (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 12))
115
 
                              "FATAL ERROR,")
116
 
        (setf ltemp 12)))
117
 
      (cond
118
 
       ((or (and (= mkntrl 2) (>= level 1)) (and (= mkntrl 1) (= level 2)))
119
 
        (f2cl-lib:fset-string
120
 
         (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp 14)))
121
 
         " PROG ABORTED,")
122
 
        (setf ltemp (f2cl-lib:int-add ltemp 14)))
123
 
       (t
124
 
        (f2cl-lib:fset-string
125
 
         (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp 16)))
126
 
         " PROG CONTINUES,")
127
 
        (setf ltemp (f2cl-lib:int-add ltemp 16))))
128
 
      (cond
129
 
       ((> lkntrl 0)
130
 
        (f2cl-lib:fset-string
131
 
         (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp 20)))
132
 
         " TRACEBACK REQUESTED")
133
 
        (setf ltemp (f2cl-lib:int-add ltemp 20)))
134
 
       (t
135
 
        (f2cl-lib:fset-string
136
 
         (f2cl-lib:fref-string temp ((+ ltemp 1) (f2cl-lib:int-add ltemp 24)))
137
 
         " TRACEBACK NOT REQUESTED")
138
 
        (setf ltemp (f2cl-lib:int-add ltemp 24))))
139
 
      (xerprn " ***" -1 (f2cl-lib:fref-string temp (1 ltemp)) 72)))
 
104
      ((> lkntrl 0)
 
105
       (cond
 
106
         ((<= level 0)
 
107
          (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 20))
 
108
                                "INFORMATIVE MESSAGE,")
 
109
          (setf ltemp 20))
 
110
         ((= level 1)
 
111
          (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 30))
 
112
                                "POTENTIALLY RECOVERABLE ERROR,")
 
113
          (setf ltemp 30))
 
114
         (t
 
115
          (f2cl-lib:fset-string (f2cl-lib:fref-string temp (1 12))
 
116
                                "FATAL ERROR,")
 
117
          (setf ltemp 12)))
 
118
       (cond
 
119
         ((or (and (= mkntrl 2) (>= level 1)) (and (= mkntrl 1) (= level 2)))
 
120
          (f2cl-lib:fset-string
 
121
           (f2cl-lib:fref-string temp
 
122
                                 ((+ ltemp 1) (f2cl-lib:int-add ltemp 14)))
 
123
           " PROG ABORTED,")
 
124
          (setf ltemp (f2cl-lib:int-add ltemp 14)))
 
125
         (t
 
126
          (f2cl-lib:fset-string
 
127
           (f2cl-lib:fref-string temp
 
128
                                 ((+ ltemp 1) (f2cl-lib:int-add ltemp 16)))
 
129
           " PROG CONTINUES,")
 
130
          (setf ltemp (f2cl-lib:int-add ltemp 16))))
 
131
       (cond
 
132
         ((> lkntrl 0)
 
133
          (f2cl-lib:fset-string
 
134
           (f2cl-lib:fref-string temp
 
135
                                 ((+ ltemp 1) (f2cl-lib:int-add ltemp 20)))
 
136
           " TRACEBACK REQUESTED")
 
137
          (setf ltemp (f2cl-lib:int-add ltemp 20)))
 
138
         (t
 
139
          (f2cl-lib:fset-string
 
140
           (f2cl-lib:fref-string temp
 
141
                                 ((+ ltemp 1) (f2cl-lib:int-add ltemp 24)))
 
142
           " TRACEBACK NOT REQUESTED")
 
143
          (setf ltemp (f2cl-lib:int-add ltemp 24))))
 
144
       (xerprn " ***" -1 (f2cl-lib:fref-string temp (1 ltemp)) 72)))
140
145
    (xerprn " *  " -1 messg 72)
141
146
    (cond
142
 
     ((> lkntrl 0)
143
 
      (tagbody
144
 
        (f2cl-lib:fformat temp ("ERROR NUMBER = " 1 (("~8D")) "~%") nerr)
145
 
        (f2cl-lib:fdo (i 16 (f2cl-lib:int-add i 1))
146
 
                      ((> i 22) nil)
147
 
          (tagbody
148
 
            (if (f2cl-lib:fstring-/= (f2cl-lib:fref-string temp (i i)) " ")
149
 
                (go label20))
150
 
           label10))
151
 
       label20
152
 
        (xerprn " *  " -1
153
 
         (f2cl-lib:f2cl-// (f2cl-lib:fref-string temp (1 15))
154
 
                           (f2cl-lib:fref-string temp (i 23)))
155
 
         72)
156
 
        (fdump))))
 
147
      ((> lkntrl 0)
 
148
       (tagbody
 
149
         (f2cl-lib:fformat temp ("ERROR NUMBER = " 1 (("~8D")) "~%") nerr)
 
150
         (f2cl-lib:fdo (i 16 (f2cl-lib:int-add i 1))
 
151
                       ((> i 22) nil)
 
152
           (tagbody
 
153
             (if (f2cl-lib:fstring-/= (f2cl-lib:fref-string temp (i i)) " ")
 
154
                 (go label20))
 
155
            label10))
 
156
        label20
 
157
         (xerprn " *  " -1
 
158
          (f2cl-lib:f2cl-// (f2cl-lib:fref-string temp (1 15))
 
159
                            (f2cl-lib:fref-string temp (i 23)))
 
160
          72)
 
161
         (fdump))))
157
162
    (cond
158
 
     ((/= lkntrl 0) (xerprn " *  " -1 " " 72)
159
 
      (xerprn " ***" -1 "END OF MESSAGE" 72) (xerprn "    " 0 " " 72)))
 
163
      ((/= lkntrl 0)
 
164
       (xerprn " *  " -1 " " 72)
 
165
       (xerprn " ***" -1 "END OF MESSAGE" 72)
 
166
       (xerprn "    " 0 " " 72)))
160
167
   label30
161
168
    (if (or (<= level 0) (and (= level 1) (<= mkntrl 1))) (go end_label))
162
169
    (cond
163
 
     ((and (> lkntrl 0)
164
 
           (< kount
165
 
              (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 maxmes))))
166
 
      (cond
167
 
       ((= level 1)
168
 
        (xerprn " ***" -1 "JOB ABORT DUE TO UNRECOVERED ERROR." 72))
169
 
       (t (xerprn " ***" -1 "JOB ABORT DUE TO FATAL ERROR." 72)))
170
 
      (multiple-value-bind
171
 
          (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
172
 
          (xersve " " " " " " -1 0 0 kdummy)
173
 
        (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
174
 
        (setf kdummy var-6))
175
 
      (xerhlt " "))
176
 
     (t (xerhlt messg)))
 
170
      ((and (> lkntrl 0)
 
171
            (< kount
 
172
               (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 maxmes))))
 
173
       (cond
 
174
         ((= level 1)
 
175
          (xerprn " ***" -1 "JOB ABORT DUE TO UNRECOVERED ERROR." 72))
 
176
         (t
 
177
          (xerprn " ***" -1 "JOB ABORT DUE TO FATAL ERROR." 72)))
 
178
       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
179
           (xersve " " " " " " -1 0 0 kdummy)
 
180
         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5))
 
181
         (setf kdummy var-6))
 
182
       (xerhlt " "))
 
183
      (t
 
184
       (xerhlt messg)))
177
185
    (go end_label)
178
186
   end_label
179
187
    (return (values nil nil nil nil nil))))