1;;; Compiled by f2cl version: 2;;; ("f2cl1.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $" 3;;; "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $" 4;;; "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $" 5;;; "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $" 6;;; "f2cl5.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $" 7;;; "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $" 8;;; "macros.l,v fceac530ef0c 2011/11/26 04:02:26 toy $") 9 10;;; Using Lisp CMU Common Lisp snapshot-2012-04 (20C Unicode) 11;;; 12;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t) 13;;; (:coerce-assigns :as-needed) (:array-type ':simple-array) 14;;; (:array-slicing nil) (:declare-common nil) 15;;; (:float-format double-float)) 16 17(in-package :slatec) 18 19 20(let* ((newlin "$$")) 21 (declare (type (simple-string 2) newlin) (ignorable newlin)) 22 (defun xerprn (prefix npref messg nwrap) 23 (declare (type (f2cl-lib:integer4) nwrap npref) 24 (type (simple-string *) messg prefix)) 25 (prog ((iu (make-array 5 :element-type 'f2cl-lib:integer4)) (nunit 0) 26 (cbuff 27 (make-array '(148) :element-type 'character :initial-element #\ )) 28 (idelta 0) (lpiece 0) (nextc 0) (lenmsg 0) (lwrap 0) (lpref 0) (i 0) 29 (n 0)) 30 (declare (type (simple-array f2cl-lib:integer4 (5)) iu) 31 (type (f2cl-lib:integer4) n i lpref lwrap lenmsg nextc lpiece 32 idelta nunit) 33 (type (simple-string 148) cbuff)) 34 (multiple-value-bind (var-0 var-1) 35 (xgetua iu nunit) 36 (declare (ignore var-0)) 37 (setf nunit var-1)) 38 (setf n (f2cl-lib:i1mach 4)) 39 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 40 ((> i nunit) nil) 41 (tagbody 42 (if (= (f2cl-lib:fref iu (i) ((1 5))) 0) 43 (setf (f2cl-lib:fref iu (i) ((1 5))) n)) 44 label10)) 45 (cond 46 ((< npref 0) 47 (setf lpref (f2cl-lib:len prefix))) 48 (t 49 (setf lpref npref))) 50 (setf lpref 51 (min (the f2cl-lib:integer4 16) (the f2cl-lib:integer4 lpref))) 52 (if (/= lpref 0) 53 (f2cl-lib:fset-string (f2cl-lib:fref-string cbuff (1 lpref)) prefix)) 54 (setf lwrap 55 (max (the f2cl-lib:integer4 16) 56 (the f2cl-lib:integer4 57 (min (the f2cl-lib:integer4 132) 58 (the f2cl-lib:integer4 nwrap))))) 59 (setf lenmsg (f2cl-lib:len messg)) 60 (setf n lenmsg) 61 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 62 ((> i n) nil) 63 (tagbody 64 (if 65 (f2cl-lib:fstring-/= (f2cl-lib:fref-string messg (lenmsg lenmsg)) 66 " ") 67 (go label30)) 68 (setf lenmsg (f2cl-lib:int-sub lenmsg 1)) 69 label20)) 70 label30 71 (cond 72 ((= lenmsg 0) 73 (f2cl-lib:fset-string 74 (f2cl-lib:fref-string cbuff ((+ lpref 1) (f2cl-lib:int-add lpref 1))) 75 " ") 76 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 77 ((> i nunit) nil) 78 (tagbody 79 (f2cl-lib:fformat (f2cl-lib:fref iu (i) ((1 5))) 80 (t (("~A")) "~%") 81 (f2cl-lib:fref-string cbuff 82 (1 83 (f2cl-lib:int-add lpref 84 1)))) 85 label40)) 86 (go end_label))) 87 (setf nextc 1) 88 label50 89 (setf lpiece 90 (f2cl-lib:index (f2cl-lib:fref-string messg (nextc lenmsg)) 91 newlin)) 92 (cond 93 ((= lpiece 0) 94 (tagbody 95 (setf idelta 0) 96 (setf lpiece 97 (min (the f2cl-lib:integer4 lwrap) 98 (the f2cl-lib:integer4 99 (f2cl-lib:int-sub (f2cl-lib:int-add lenmsg 1) 100 nextc)))) 101 (cond 102 ((< lpiece (f2cl-lib:int-add lenmsg 1 (f2cl-lib:int-sub nextc))) 103 (f2cl-lib:fdo (i (f2cl-lib:int-add lpiece 1) 104 (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) 105 ((> i 2) nil) 106 (tagbody 107 (cond 108 ((f2cl-lib:fstring-= 109 (f2cl-lib:fref-string messg 110 ((+ nextc i (f2cl-lib:int-sub 1)) 111 (f2cl-lib:int-add nextc 112 i 113 (f2cl-lib:int-sub 114 1)))) 115 " ") 116 (setf lpiece (f2cl-lib:int-sub i 1)) 117 (setf idelta 1) 118 (go label54))) 119 label52)))) 120 label54 121 (f2cl-lib:fset-string 122 (f2cl-lib:fref-string cbuff 123 ((+ lpref 1) 124 (f2cl-lib:int-add lpref lpiece))) 125 (f2cl-lib:fref-string messg 126 (nextc 127 (f2cl-lib:int-sub 128 (f2cl-lib:int-add nextc lpiece) 129 1)))) 130 (setf nextc (f2cl-lib:int-add nextc lpiece idelta)))) 131 ((= lpiece 1) 132 (setf nextc (f2cl-lib:int-add nextc 2)) 133 (go label50)) 134 ((> lpiece (f2cl-lib:int-add lwrap 1)) 135 (tagbody 136 (setf idelta 0) 137 (setf lpiece lwrap) 138 (f2cl-lib:fdo (i (f2cl-lib:int-add lpiece 1) 139 (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) 140 ((> i 2) nil) 141 (tagbody 142 (cond 143 ((f2cl-lib:fstring-= 144 (f2cl-lib:fref-string messg 145 ((+ nextc i (f2cl-lib:int-sub 1)) 146 (f2cl-lib:int-add nextc 147 i 148 (f2cl-lib:int-sub 149 1)))) 150 " ") 151 (setf lpiece (f2cl-lib:int-sub i 1)) 152 (setf idelta 1) 153 (go label58))) 154 label56)) 155 label58 156 (f2cl-lib:fset-string 157 (f2cl-lib:fref-string cbuff 158 ((+ lpref 1) 159 (f2cl-lib:int-add lpref lpiece))) 160 (f2cl-lib:fref-string messg 161 (nextc 162 (f2cl-lib:int-sub 163 (f2cl-lib:int-add nextc lpiece) 164 1)))) 165 (setf nextc (f2cl-lib:int-add nextc lpiece idelta)))) 166 (t 167 (setf lpiece (f2cl-lib:int-sub lpiece 1)) 168 (f2cl-lib:fset-string 169 (f2cl-lib:fref-string cbuff 170 ((+ lpref 1) (f2cl-lib:int-add lpref lpiece))) 171 (f2cl-lib:fref-string messg 172 (nextc 173 (f2cl-lib:int-sub 174 (f2cl-lib:int-add nextc lpiece) 175 1)))) 176 (setf nextc (f2cl-lib:int-add nextc lpiece 2)))) 177 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 178 ((> i nunit) nil) 179 (tagbody 180 (f2cl-lib:fformat (f2cl-lib:fref iu (i) ((1 5))) 181 (t (("~A")) "~%") 182 (f2cl-lib:fref-string cbuff 183 (1 184 (f2cl-lib:int-add lpref 185 lpiece)))) 186 label60)) 187 (if (<= nextc lenmsg) (go label50)) 188 (go end_label) 189 end_label 190 (return (values nil nil nil nil))))) 191 192(in-package #-gcl #:cl-user #+gcl "CL-USER") 193#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 194(eval-when (:load-toplevel :compile-toplevel :execute) 195 (setf (gethash 'fortran-to-lisp::xerprn 196 fortran-to-lisp::*f2cl-function-info*) 197 (fortran-to-lisp::make-f2cl-finfo 198 :arg-types '((fortran-to-lisp::a nil) (fortran-to-lisp::integer4) 199 (fortran-to-lisp::a nil) (fortran-to-lisp::integer4)) 200 :return-values '(nil nil nil nil) 201 :calls '(fortran-to-lisp::i1mach fortran-to-lisp::xgetua)))) 202 203