src/numerical/slatec/xerprn.lisp

   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 #: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