1;; macros.l - all the basic macros 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4;;;;;;;;Hamilton, New Zeland 1992-95 - all rights reserved;;;;;;;;;;;;;;;; 5;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6(in-package :f2cl-lib) 7 8(defparameter *f2cl-macros-version* 9 "$Id: macros.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $") 10 11(eval-when 12 #+gcl (compile load eval) 13 #-gcl (:compile-toplevel :load-toplevel :execute) 14 (proclaim '(special *verbose*))) 15;;---------------------------------------------------------------------------- 16(defvar *check-array-bounds* nil 17 "If non-NIL, generated code checks for array bounds. If NIL, checking 18is not included") 19 20;;------------------------------------------------------------------------------ 21;; 22;; Define the equivalent types between Fortran and Lisp. This MUST 23;; match the types given in f2cl1.l so keep it in sync! 24(deftype logical () 25 `(member t nil)) 26 27;; Decide what you want integer*4 to be. Good choices are fixnum or 28;; (signed-byte 32). The latter is good only if your compiler does a 29;; good job with this type. If you aren't sure, use fixnum. CMUCL 30;; does a good job with (signed-byte 32). 31;; 32;; If you change this, you may need to change some of the macros 33;; below, such as INT and AINT! 34 35#+(or cmu scl sbcl ecl) 36(deftype integer4 (&optional (low #x-80000000) (high #x7fffffff)) 37 `(integer ,low ,high)) 38#-(or cmu scl sbcl ecl) 39(deftype integer4 (&optional low high) 40 (declare (ignore low high)) 41 'fixnum) 42 43(deftype integer2 () 44 `(signed-byte 16)) 45(deftype integer1 () 46 `(signed-byte 8)) 47(deftype real8 () 48 'double-float) 49(deftype real4 () 50 'single-float) 51(deftype complex8 () 52 `(complex single-float)) 53(deftype complex16 () 54 `(complex double-float)) 55 56(deftype array-double-float () 57 `(array double-float (*))) 58(deftype array-integer4 () 59 `(array integer4 (*))) 60(deftype array-single-float () 61 `(array single-float (*))) 62(deftype array-strings () 63 `(array string (*))) 64 65(defconstant %false% nil) 66(defconstant %true% t) 67 68;;------------------------------------------------------------------------------ 69 70;;----------------------------------------------------------------------------- 71 72;; Array dimensions are (d1, d2, d3, ...) 73;; 74;; Then x(n1, n2, n3, ...) means index is 75;; 76;; n1 + d1*(n2 + d2*(n3 + d3*(n4 + d4*(n5)))) 77 78;; Return an expression that computes the column major index given the 79;; indices and the bounds on each dimension. The bounds are a list of 80;; the upper and lower bounds for each dimension. 81(defun col-major-index (indices dims) 82 (flet ((get-offset (n bound) 83 (let ((lo (first bound))) 84 (if (and (numberp lo) (zerop lo)) 85 n 86 `(the fixnum (- (the fixnum ,n) (the fixnum ,lo)))))) 87 (get-size (bound) 88 (destructuring-bind (lo hi) 89 bound 90 (cond ((numberp lo) 91 (cond ((numberp hi) 92 (1+ (- hi lo))) 93 ((= lo 1) 94 hi) 95 (t 96 `(- ,hi ,(- lo 1))))) 97 (t 98 `(the fixnum (- ,hi (the fixnum (- (the fixnum ,lo) 1))))))))) 99 (let* ((rev-idx (reverse indices)) 100 (rev-dim (reverse dims)) 101 (idx (get-offset (first rev-idx) (first rev-dim)))) 102 (do ((d (rest rev-dim) (rest d)) 103 (n (rest rev-idx) (rest n))) 104 ((endp d) 105 idx) 106 (setf idx `(the fixnum (+ ,(get-offset (first n) (first d)) 107 (the fixnum (* ,(get-size (first d)) ,idx))))))))) 108 109(defun check-array-bounds (indices bounds) 110 `(and ,@(mapcar #'(lambda (idx dim) 111 `(<= ,(first dim) ,idx ,(second dim))) 112 indices bounds))) 113 114(defmacro fref (arr indices bounds &optional offset) 115 (if *check-array-bounds* 116 `(aref ,arr (if ,(check-array-bounds indices bounds) 117 (the fixnum (+ (the fixnum ,(or offset 0)) ,(col-major-index indices bounds))) 118 (error "Out of bounds index for array ~S" 119 ',arr))) 120 `(aref ,arr (the fixnum (+ (the fixnum ,(or offset 0)) ,(col-major-index indices bounds)))))) 121 122(defmacro fset (a b) 123 `(setf (fref ,(second a) ,@(cddr a)) ,b)) 124 125(defmacro fref-string (s range) 126 `(subseq ,s (1- ,(first range)) ,(second range))) 127 128(defmacro fset-string (a b) 129 `(setf (fref-string ,(second a) ,(third a)) (string ,b))) 130 131(defmacro f2cl-// (a b) 132 `(concatenate 'string ,a ,b)) 133 134;; (with-array-data ((data-var offset-var array)) 135;; ... 136;; ) 137 138(defun find-array-data (array) 139 (declare (type (array * (*)) array)) 140 (let ((offset 0)) 141 (declare (type fixnum offset) 142 (optimize (speed 3) (safety 0))) 143 (loop 144 (multiple-value-bind (displaced-to index-offset) 145 (array-displacement array) 146 (when (null displaced-to) 147 (return-from find-array-data (values array offset))) 148 (incf offset index-offset) 149 (setf array displaced-to))))) 150 151(defmacro with-array-data ((data-var offset-var array) &rest body) 152 `(multiple-value-bind (,data-var ,offset-var) 153 (find-array-data ,array) 154 ,@body)) 155 156(defun multi-array-data-aux (array-info body) 157 (let ((results body)) 158 (dolist (a (reverse array-info)) 159 (destructuring-bind (array a-type var-name offset-var) 160 a 161 (let ((atype (if (subtypep a-type 'character) 162 `(simple-string) 163 `(simple-array ,a-type (*))))) 164 (setf results 165 `((multiple-value-bind (,var-name ,offset-var) 166 (find-array-data ,array) 167 (declare (ignorable ,offset-var ,var-name) 168 (type f2cl-lib:integer4 ,offset-var) 169 (type ,atype ,var-name)) 170 ,@results)))))) 171 (first results))) 172 173(defmacro with-multi-array-data (array-info &rest body) 174 (multi-array-data-aux array-info body)) 175 176;; Create an array slice for the array named VNAME whose elements are 177;; of type TYPE. The slice starts at the indices INDICES and the 178;; original array has dimensions given by BOUND. 179;; 180;; This is done by making a displaced array to VNAME with the 181;; appropriate offset. 182(defmacro array-slice (vname type indices bounds &optional offset) 183 ;; To figure the size of the sliced array, use ARRAY-TOTAL-SIZE 184 ;; instead of the f2cl derived/declared BOUNDS, just in case we 185 ;; screwed up or in case we changed the size of the array in some 186 ;; other way. This isn't possible in a function, but the array 187 ;; might be in a common block and we could change the dimensions of 188 ;; the common block at runtime. (Some Fortran code like mpfun does 189 ;; this, although it's actually illegal. Neat hack to "dynamically" 190 ;; change the dimensions. Of course, for this to work in Fortran, 191 ;; the common block has to contain exactly that one array, or the 192 ;; array must be the last element of the common block.) 193 ;; 194 ;; Note: In some places in LAPACK, an array slice is taken where the 195 ;; slice exceeds the bounds of the array. However, the array is 196 ;; never accessed. What are we to do? We could modify the LAPACK 197 ;; routines (everywhere!) to check for this, or we can silently make 198 ;; array-slice make a 0-element array. If the array is then 199 ;; accessed, we should get an error at the point of access, not the 200 ;; point of creation. 201 ;; 202 ;; This seems somewhat reasonable, so let's do that for array 203 ;; slices. 204 `(make-array (max 0 (- (array-total-size ,vname) 205 (the fixnum 206 (+ ,(col-major-index indices bounds) 207 (or ,offset 0))))) 208 :element-type ',type 209 :displaced-to ,vname 210 :displaced-index-offset (min (array-total-size ,vname) 211 (the fixnum 212 (+ ,(col-major-index indices bounds) 213 (or ,offset 0)))))) 214 215;; Compute an initializer for make-array given the data in the list 216;; DATA. The array has en element type of TYPE and has dimensions of 217;; DIMS. 218(defmacro array-initialize (type dims data) 219 (let ((data-list (gensym)) 220 (data-len (length data)) 221 (total-length (gensym))) 222 `(let* ((,data-list (list ,@data)) 223 (,total-length (reduce #'* (list ,@dims)))) 224 (cond ((< ,data-len ,total-length) 225 ;; Need to append some data. 226 (append ,data-list (make-list (- ,total-length ,data-len) 227 :initial-element (coerce 0 ',type)))) 228 ((> ,data-len ,total-length) 229 ;; Need to truncate some data 230 (subseq ,data-list 0 ,total-length)) 231 (t 232 ,data-list))))) 233 234;;---------------------------------------------------------------------------- 235 236#-aclpc (defmacro while (con &rest body) 237 `(loop (if (not ,con) (return t)) ,@body)) 238;;------------------------------------------------------------------ 239 240(defmacro fortran_comment (&rest args) 241 (declare (ignore args))) 242 243;;---------------------------------------------------------------------------- 244;; fdo has similar syntax as do except there will only be one do_vble 245 246(defmacro fdo (do_vble_clause predicate_clause &rest body) 247 (let ((step (gensym (symbol-name '#:step-))) 248 (iteration_count (gensym (symbol-name '#:cnt-))) 249 (loop-var (first do_vble_clause))) 250 `(prog* ((,step ,(third (third do_vble_clause))) 251 (,iteration_count 252 (max 0 (the integer4 253 (truncate (the integer4 254 (+ (the integer4 (- ,(third (first predicate_clause)) 255 ,(second do_vble_clause))) 256 ,step)) 257 ,step)) 258 ))) 259 (declare (type integer4 ,step ,iteration_count)) 260 ;; initialise loop variable 261 (setq ,loop-var ,(second do_vble_clause)) 262 loop 263 (return 264 (cond ; all iterations done 265 ((zerop ,iteration_count) nil) 266 ;; execute loop, in/de-crement loop vble and decrement cntr 267 ,(list 't 268 (append '(tagbody) 269 (append 270 (append body 271 `(continue 272 (setq ,loop-var (the integer4 ,(third do_vble_clause)) 273 ,iteration_count (the integer4 (1- ,iteration_count))))) 274 '((go loop))))))) 275 exit))) 276 277;;---------------------------------------------------------------------------- 278;; macro for division 279 280(defmacro f2cl/ (x y) 281 (let ((top (gensym)) 282 (bot (gensym))) 283 `(let ((,top ,x) 284 (,bot ,y)) 285 (if (and (typep ,top 'integer) 286 (typep ,bot 'integer)) 287 (values (the integer4 (truncate ,top ,bot))) 288 (/ ,top ,bot))))) 289 290(defmacro int-add (arg &rest more-args) 291 (if (null more-args) 292 arg 293 (if (> (length more-args) 1) 294 `(the integer4 (+ ,arg (int-add ,@more-args))) 295 `(the integer4 (+ ,arg ,@more-args))))) 296 297(defun convert-int-sub (args) 298 (let ((nargs (length args))) 299 (case nargs 300 (1 301 `(the integer4 (- ,(first args)))) 302 (2 303 `(the integer4 (- ,(first args) ,(second args)))) 304 (t 305 (let ((result `(the integer4 (- ,(first args) ,(second args))))) 306 (dolist (arg (rest (rest args))) 307 (setf result `(the integer4 (- ,result ,arg)))) 308 result))))) 309 310(defmacro int-sub (&rest args) 311 (convert-int-sub args)) 312 313(defmacro int-mul (arg &rest more-args) 314 (if (null more-args) 315 arg 316 (if (> (length more-args) 1) 317 `(the integer4 (* ,arg (int-mul ,@more-args))) 318 `(the integer4 (* ,arg ,@more-args))))) 319 320 321;; macro for a lisp equivalent of Fortran arithmetic IFs 322(defmacro arithmetic-if (pred s1 s2 s3) 323 (let ((tst (gensym))) 324 `(let ((,tst ,pred)) 325 (cond ((< ,tst 0) ,s1) 326 ((= ,tst 0) ,s2) 327 (t ,s3))))) 328 329;; macro for a lisp equivalent of Fortran computed GOTOs 330(defun computed-goto-aux (tags) 331 (let ((idx 0) 332 (result '())) 333 (dolist (tag tags (nreverse result)) 334 (incf idx) 335 (push `(,idx (go ,tag)) result)))) 336 337(defmacro computed-goto (tag-lst i) 338 `(case ,i 339 ,@(computed-goto-aux tag-lst))) 340 341;; macro for a lisp equivalent of Fortran assigned GOTOs 342(eval-when 343 #+gcl (compile load eval) 344 #-gcl (:load-toplevel :compile-toplevel :execute) 345(defun make-label (n) 346 (read-from-string (concatenate 'string (symbol-name :label) (princ-to-string n)))) 347 348 349(defun assigned-goto-aux (tag-list) 350 (let ((cases nil)) 351 (dolist (tag tag-list) 352 (push `(,tag (go ,(f2cl-lib::make-label tag))) 353 cases)) 354 (push `(t (error "Unknown label for assigned goto")) cases) 355 (nreverse cases))) 356) 357 358 359;; macro for a lisp equivalent of Fortran assigned GOTOs 360(defmacro assigned-goto (var tag-list) 361 `(case ,var 362 ,@(assigned-goto-aux tag-list))) 363 364;;----------------------------------------------------------------------------- 365;; 366;; Define the intrinsic functions 367;; 368;; Reference: The Fortran 77 standard found at www.fortran.com. Section 15.10 369 370;; INT is the generic name as well as the integer version. IFIX is 371;; the same. IDINT is the double version. 372 373(declaim (inline int ifix idfix)) 374 375#-(or cmu scl) 376(defun int (x) 377 ;; We use fixnum here because f2cl thinks Fortran integers are 378 ;; fixnums. If this should change, we need to change the ranges 379 ;; here as well. 380 (etypecase x 381 (integer 382 (the integer4 x)) 383 (single-float 384 (truncate (the (single-float #.(float most-negative-fixnum) 385 #.(float most-positive-fixnum)) 386 x))) 387 (double-float 388 (truncate (the (double-float #.(float most-negative-fixnum 1d0) 389 #.(float most-positive-fixnum 1d0)) 390 x))) 391 ((complex single-float) 392 (the integer4 393 (truncate (the (single-float #.(float (- (ash 1 31))) 394 #.(float (1- (ash 1 31)))) 395 (realpart x))))) 396 ((complex double-float) 397 (the integer4 398 (truncate (the (double-float #.(float (- (ash 1 31)) 1d0) 399 #.(float (1- (ash 1 31)) 1d0)) 400 (realpart x))))))) 401 402#+(or cmu scl) 403(defun int (x) 404 ;; For CMUCL, we support the full 32-bit integer range, so INT can 405 ;; return a full 32-bit integer. Tell CMUCL that this is true so we 406 ;; generate fast code. If this is not true, the original Fortran 407 ;; code was wrong. 408 (etypecase x 409 (integer 410 (the integer4 x)) 411 (single-float 412 (the integer4 413 (truncate (the (single-float #.(float (- (ash 1 31))) 414 #.(float (1- (ash 1 31)))) 415 x)))) 416 (double-float 417 (the integer4 418 (truncate (the (double-float #.(float (- (ash 1 31)) 1d0) 419 #.(float (1- (ash 1 31)) 1d0)) 420 x)))) 421 ((complex single-float) 422 (the integer4 423 (truncate (the (single-float #.(float (- (ash 1 31))) 424 #.(float (1- (ash 1 31)))) 425 (realpart x))))) 426 ((complex double-float) 427 (the integer4 428 (truncate (the (double-float #.(float (- (ash 1 31)) 1d0) 429 #.(float (1- (ash 1 31)) 1d0)) 430 (realpart x))))))) 431 432 433(defun ifix (x) 434 (int x)) 435(defun idfix (x) 436 (int x)) 437 438;; AINT is the generic and specific function for real; DINT, for 439;; double. It truncates its arg towards zero and returns the integer 440;; as a floating-point number of the same type as its arg. 441;; 442;; ANINT is the generic and specific function for real; DNINT, for 443;; double. It rounds to the nearest integer and returns the result as 444;; a float of the same type. 445;; 446;; NINT is the generic and specific function for real; IDNINT, for 447;; double. Does the same as ANINT, but the result is an integer. 448 449(declaim (inline aint dint anint dnint nint idnint)) 450 451;; This is based on the algorithm given by Anton Ertl in 452;; comp.arch.arithmetic on Oct. 26, 2002: 453;; 454;; #define X 9007199254740992. /* 2^53 */ 455;; double rint(double r) 456;; { 457;; if (r<0.0) 458;; return (r+X)-X; 459;; else 460;; return (r-X)+X; 461;; } 462;; 463;; This assumes that we in round-to-nearest mode (the default). 464;; 465;; These only work if you have IEEE FP arithmetic. There are 2 466;; versions given below. One is for non-x87, which assumes that 467;; single and double FP numbers are properly rounded after each 468;; operation. The version for x87 stores away a value to make sure 469;; the rounding happens correctly. 470;; 471;; Finally, the last version if for platforms where none of this 472;; holds and we call ftruncate. 473;; 474;; With CMUCL pre-18e on sparc, this definition of aint reduces the 475;; cost of MPNORM (from MPFUN) from 48.89 sec to 24.88 sec (a factor 476;; of 2!) when computing pi to 29593 digits or os. 477 478(declaim (inline rint-s rint-d)) 479#+(and cmu (or :sse2 (not x86))) 480(progn 481(defun rint-s (x) 482 (declare (single-float x)) 483 (let ((const (scale-float 1f0 24))) 484 (if (>= x 0) 485 (+ (- x const) const) 486 (- (+ x const) const)))) 487 488(defun rint-d (x) 489 (declare (double-float x)) 490 (let ((const (scale-float 1d0 53))) 491 (if (>= x 0) 492 (+ (- x const) const) 493 (- (+ x const) const)))) 494) 495 496#+(and cmu (and x86 x87)) 497(progn 498(defun rint-s (x) 499 (declare (single-float x)) 500 (let ((junks (make-array 1 :element-type 'single-float)) 501 (const (scale-float 1f0 24))) 502 (if (>= x 0) 503 (progn 504 (setf (aref junks 0) (- x const)) 505 (+ (aref junks 0) const)) 506 (progn 507 (setf (aref junks 0) (+ x const)) 508 (- (aref junks 0) const))))) 509 510(defun rint-d (x) 511 (declare (double-float x)) 512 (let ((junkd (make-array 1 :element-type 'double-float)) 513 (const (scale-float 1d0 53))) 514 (if (>= x 0) 515 (progn 516 (setf (aref junkd 0) (- x const)) 517 (+ (aref junkd 0) const)) 518 (progn 519 (setf (aref junkd 0) (+ x const)) 520 (- (aref junkd 0) const))))) 521) 522 523;; Truncate x to an integer. 524#+cmu 525(defun aint (x) 526 ;; rint above is fast. We use it to round the number, and then 527 ;; adjust the result to truncate. 528 (etypecase x 529 (single-float 530 (let ((r (rint-s x))) 531 (if (> (abs r) (abs x)) 532 (if (> r 0) 533 (- r 1) 534 (+ r 1)) 535 r))) 536 (double-float 537 (let ((r (rint-d x))) 538 (if (> (abs r) (abs x)) 539 (if (> r 0) 540 (- r 1) 541 (+ r 1)) 542 r))))) 543 544 545#-cmu 546(defun aint (x) 547 ;; ftruncate is exactly what we want. 548 (etypecase x 549 (single-float 550 (locally 551 (declare (optimize (space 0) (speed 3))) 552 (values (ftruncate (the single-float x))))) 553 (double-float 554 (locally 555 (declare (optimize (space 0) (speed 3))) 556 (values (ftruncate (the double-float x))))))) 557 558(defun dint (x) 559 (aint x)) 560 561(defun anint (x) 562 (values (fround x))) 563(defun dnint (x) 564 (values (fround x))) 565(defun nint (x) 566 (values (round x))) 567(defun idnint (x) 568 (values (round x))) 569 570;; Type conversion 571;; 572;; FREAL is F2CL's version of the Fortran REAL which takes converts 573;; its arg to a real. SNGL is the same. DBLE returns a double. They 574;; also return the real part of a complex number. CMPLX takes one or 575;; two args and creates a complex number. 576 577(declaim (inline freal sngl dble dfloat cmplx)) 578(defun freal (x) 579 (coerce (realpart x) 'single-float)) 580 581(defun sngl (x) 582 (coerce (realpart x) 'single-float)) 583 584(defun dble (x) 585 (coerce (realpart x) 'double-float)) 586 587(defun dfloat (x) 588 (coerce (realpart x) 'double-float)) 589 590(defun cmplx (x &optional y) 591 (complex x (if y y 0))) 592 593(defun dcmplx (x &optional y) 594 (coerce (complex x (if y y 0)) '(complex double-float))) 595 596(defun ichar (c) 597 (if (stringp c) 598 (char-int (aref c 0)) 599 (char-int c))) 600(defun fchar (i) ;intrinsic function char 601 (code-char i)) 602 603(declaim (inline iabs dabs cabs cdabs amod dmod)) 604#-aclpc 605(defun iabs (x) 606 (declare (type integer4 x)) 607 (abs x)) 608(defun dabs (x) 609 (declare (type double-float x)) 610 (abs x)) 611(defun cabs (x) 612 (declare (type complex x)) 613 (abs x)) 614(defun cdabs (x) 615 (declare (type (complex double-float) x)) 616 (abs x)) 617 618(defun amod (x y) 619 (declare (type single-float x y)) 620 (mod x y)) 621(defun dmod (x y) 622 (declare (type double-float x y)) 623 (mod x y)) 624 625 626;; Transfer of sign. SIGN is the generic and specific function for 627;; real. ISIGN is for integers; DSIGN for doubles. Basically 628;; computes sign(a2)*|a1|. 629 630(declaim (inline isign sign dsign)) 631 632(defun isign (x y) 633 (declare (type integer4 x y)) 634 (if (>= y 0) 635 (the integer4 (abs x)) 636 (the integer4 (- (the integer4 (abs x)))))) 637 638;; Fortran 77 says SIGN is a generic! 639(defun sign (x y) 640 (declare (type (or integer4 single-float double-float) x y)) 641 (etypecase x 642 (integer4 643 (isign x y)) 644 (single-float 645 (float-sign y x)) 646 (double-float 647 (float-sign y x)))) 648 649(defun dsign (x y) 650 (declare (type double-float x y)) 651 (float-sign y x)) 652 653;; Positive difference. DIM is the generic and specific function for 654;; real. IDIM is for integers; DDIM, doubles. 655;; 656;; If a1 > a2, returns a1-a2, otherwise 0. Basically the same as 657;; max(0, a1-a2). 658(declaim (inline idim dim ddim)) 659(defun idim (x y) 660 (declare (type integer4 x y)) 661 (max 0 (- x y))) 662 663(defun dim (x y) 664 (declare (type (or integer4 single-float double-float) x y)) 665 (etypecase x 666 (integer4 667 (max 0 (- x y))) 668 (single-float 669 (max 0f0 (- x y))) 670 (double-float 671 (max 0d0 (- x y))))) 672 673(defun ddim (x y) 674 (declare (type double-float x y)) 675 (max 0d0 (- x y))) 676 677;; Double-precision product. How this is done isn't specified, but I 678;; suspect the real args are converted to doubles and then the product 679;; is computed. 680(defun dprod (x y) 681 (declare (single-float x y)) 682 (* (float x 1d0) (float y 1d0))) 683 684;; The max and min functions. 685;; 686;; MAX is the generic. MAX0, AMAX1, and DMAX1 returns the max of the 687;; args with the same type as the args. 688;; 689;; AMAX0 takes integer args and returns the max as a real. MAX1 takes 690;; real args and returns the max as a integer. (How the conversion is 691;; done isn't specified.) 692;; 693;; Should we make these macros that expand directly to the appropriate 694;; max? 695(defun max0 (x y &rest z) 696 #-gcl(declare (integer x y)) 697 (apply #'max x y z)) 698(defun amax1 (x y &rest z) 699 #-gcl(declare (single-float x y)) 700 (apply #'max x y z)) 701(defun dmax1 (x y &rest z) 702 #-gcl(declare (double-float x y)) 703 (apply #'max x y z)) 704(defun max1 (x y &rest z) 705 #-gcl(declare (single-float x y)) 706 (int (apply #'max x y z))) 707(defun amax0 (x y &rest z) 708 #-gcl(declare (type integer4 x y)) 709 (float (apply #'max x y z) 1f0)) 710 711(defun min0 (x y &rest z) 712 (apply #'min x y z)) 713(defun amin1 (x y &rest z) 714 (apply #'min x y z)) 715(defun dmin1 (x y &rest z) 716 (apply #'min x y z)) 717 718(defun amin0 (x y &rest z) 719 (float (apply #'min x y z))) 720(defun min1 (x y &rest z) 721 (nint (apply #'min x y z))) 722 723;; Define some compile macros for these max/min functions. 724#+(or cmu scl) 725(progn 726(define-compiler-macro max0 (&rest args) 727 `(max ,@args)) 728(define-compiler-macro amax1 (&rest args) 729 `(max ,@args)) 730(define-compiler-macro dmax1 (&rest args) 731 `(max ,@args)) 732(define-compiler-macro min0 (&rest args) 733 `(min ,@args)) 734(define-compiler-macro amin1 (&rest args) 735 `(min ,@args)) 736(define-compiler-macro dmin1 (&rest args) 737 `(min ,@args)) 738(define-compiler-macro min1 (&rest args) 739 `(nint (min ,@args))) 740 741(define-compiler-macro amax0 (&rest args) 742 `(float (max ,@args))) 743(define-compiler-macro max1 (&rest args) 744 `(nint (max ,@args))) 745 746(define-compiler-macro amin0 (&rest args) 747 `(float (min ,@args))) 748(define-compiler-macro min1 (&rest args) 749 `(nint (min ,@args))) 750) ; end progn 751 752(defun len (s) 753 (length s)) 754 755;; From http://www.fortran.com/fortran/F77_std/rjcnf0001-sh-15.html#sh-15.10: 756;; 757;; INDEX(a1 ,a2) returns an integer value indicating the starting 758;; position within the character string a1 of a substring identical 759;; to string a2 . If a2 occurs more than once in a1 , the starting 760;; position of the first occurrence is returned. 761;; 762;; If a2 does not occur in a1 , the value zero is returned. Note 763;; that zero is returned if LEN(a1) < LEN(a2). 764;; 765;; Thus the arguments are in the opposite order for CL's SEARCH function. 766(defun index (s1 s2) 767 (or (search s2 s1) 0)) 768 769;; These string operations need some work! 770(defun lge (s1 s2) 771 (string>= s1 s2)) 772(defun lgt (s1 s2) 773 (string> s1 s2)) 774(defun lle (s1 s2) 775 (string<= s1 s2)) 776(defun llt (s1 s2) 777 (string< s1 s2)) 778 779(defun fstring-/= (s1 s2) 780 (not (string= s1 s2))) 781(defun fstring-= (s1 s2) 782 (string= s1 s2)) 783(defun fstring-> (s1 s2) 784 (string> s1 s2)) 785(defun fstring->= (s1 s2) 786 (string>= s1 s2)) 787(defun fstring-< (s1 s2) 788 (string< s1 s2)) 789(defun fstring-<= (s1 s2) 790 (string<= s1 s2)) 791 792 793;; AIMAG: imaginary part of a complex number 794;; CONJG: conjugate of a complex number 795(declaim (inline aimag conjg dconjg dimag)) 796(defun aimag (c) 797 (imagpart c)) 798(defun dimag (c) 799 (declare (type (complex double-float) c)) 800 (imagpart c)) 801(defun conjg (c) 802 (conjugate c)) 803(defun dconjg (c) 804 (declare (type (complex double-float) c)) 805 (conjugate c)) 806 807(declaim (inline fsqrt flog)) 808(defun fsqrt (x) 809 (typecase x 810 (single-float 811 (sqrt (the (or (single-float (0f0)) (member 0f0)) x))) 812 (double-float 813 (sqrt (the (or (double-float (0d0)) (member 0d0)) x))) 814 (t 815 (sqrt x)))) 816 817(defun flog (x) 818 (typecase x 819 (single-float 820 (log (the (or (single-float (0f0)) (member 0f0)) x))) 821 (double-float 822 (log (the (or (double-float (0d0)) (member 0d0)) x))) 823 (t 824 (log x)))) 825 826;; Tell Lisp that the arguments always have the correct range. If 827;; this is not true, the original Fortran code was broken anyway, so 828;; GIGO (garbage in, garbage out). 829 830(declaim (inline dsqrt csqrt zsqrt alog dlog clog alog10 dlog10)) 831(defun dsqrt (x) 832 (declare (type (double-float 0d0) x)) 833 (sqrt x)) 834(defun csqrt (x) 835 (sqrt x)) 836(defun zsqrt (x) 837 (sqrt x)) 838(defun alog (x) 839 (declare (type (or (single-float (0f0)) (member 0f0)) x)) 840 (log x)) 841(defun dlog (x) 842 (declare (type (or (double-float (0d0)) (member 0d0)) x)) 843 (log x)) 844(defun clog (x) 845 (log x)) 846(defun alog10 (x) 847 (declare (type (or (single-float (0f0)) (member 0f0)) x)) 848 (log x 10f0)) 849(defun dlog10 (x) 850 (declare (type (or (double-float (0d0)) (member 0d0)) x)) 851 (log x 10.0d0)) 852 853(declaim (inline log10)) 854(defun log10 (x) 855 (typecase x 856 (single-float 857 (log (the (or (single-float (0.0f0)) (member 0f0)) x) 10f0)) 858 (double-float 859 (log (the (or (double-float (0.0d0)) (member 0d0)) x) 10d0)) 860 (t 861 (/ (log x) 862 (typecase x 863 ((complex double-float) 864 10d0) 865 ((complex single-float) 866 10f0) 867 (t 868 (coerce 10 (type-of (realpart x))))))))) 869 870(declaim (inline dexp cexp)) 871(defun dexp (x) 872 (declare (type double-float x)) 873 (exp x)) 874(defun cexp (x) 875 (declare (type complex x)) 876 (exp x)) 877 878(declaim (inline dsin csin dcos ccos dtan ctan dasin dacos datan atan2 datan2 dsinh dcosh dtanh)) 879(defun dsin (x) 880 (declare (type double-float x)) 881 (sin x)) 882(defun csin (x) 883 (declare (type complex x)) 884 (sin x)) 885 886(defun dcos (x) 887 (declare (type double-float x)) 888 (cos x)) 889(defun ccos (x) 890 (declare (type complex x)) 891 (cos x)) 892 893(defun dtan (x) 894 (declare (type double-float x)) 895 (tan x)) 896(defun ctan (x) 897 (declare (type complex x)) 898 (tan x)) 899 900(defun dasin (x) 901 (declare (type double-float x)) 902 (asin x)) 903(defun dacos (x) 904 (declare (type double-float x)) 905 (acos x)) 906(defun datan (x) 907 (declare (type double-float x)) 908 (atan x)) 909(defun atan2 (x y) 910 (declare (type single-float x)) 911 (atan x y)) 912(defun datan2 (x y) 913 (declare (type double-float x y)) 914 (atan x y)) 915 916(defun dsinh (x) 917 (declare (type double-float x)) 918 (sinh x)) 919(defun dcosh (x) 920 (declare (type double-float x)) 921 (cosh x)) 922(defun dtanh (x) 923 (declare (type double-float x)) 924 (tanh x)) 925 926(declaim (inline ffloat)) 927(defun ffloat (x) 928 (coerce x 'single-float)) 929 930(defun process-implied-do (ido array-bnds var-types init) 931 (destructuring-bind (data-vars &rest looping) 932 ido 933 (labels 934 ((convert-type (type) 935 (if (eq type 'integer4) 936 `(truncate (pop ,init)) 937 `(coerce (pop ,init) ',type))) 938 (map-vars (v) 939 (mapcar #'(lambda (x b vt) 940 `(fset (fref ,(first x) ,(second x) ,b) 941 ,(convert-type vt))) 942 v array-bnds var-types))) 943 (let ((body (map-vars data-vars))) 944 (dolist (loopvar looping) 945 (destructuring-bind (index-var start end &optional step) 946 loopvar 947 (setf body `((do ((,index-var ,start (+ ,index-var ,(or step 1)))) 948 ((> ,index-var ,end)) 949 ,@body))))) 950 (car body))))) 951 952 953;; Process implied do loops for data statements 954(defmacro data-implied-do (implied-do array-bnds var-types vals) 955 (let ((v (gensym))) 956 `(let ((,v (list ,@vals))) 957 ,(process-implied-do implied-do array-bnds var-types v)))) 958 959;;----------------------------------------------------------------------------- 960 961;; Map Fortran logical unit numbers to Lisp streams 962 963#-gcl 964(defparameter *lun-hash* 965 (make-hash-table)) 966 967#+gcl 968(defvar *lun-hash* 969 (make-hash-table)) 970 971(defun lun->stream (lun &optional readp) 972 (let ((stream (gethash lun *lun-hash*))) 973 (if stream 974 stream 975 (cond ((eql lun 5) 976 ;; Always standard input 977 (setf (gethash lun *lun-hash*) *standard-input*)) 978 ((or (eql lun 6) 979 (eql lun t)) 980 ;; Always standard output 981 (setf (gethash lun *lun-hash*) *standard-output*)) 982 ((integerp lun) 983 ;; All other cases open a file fort<n>.dat 984 (setf (gethash lun *lun-hash*) 985 (open (format nil "fort~d.dat" lun) 986 :direction :io 987 :if-exists :rename))) 988 ((stringp lun) 989 (setf (gethash lun *lun-hash*) 990 (if readp 991 (make-string-input-stream lun) 992 (make-string-output-stream)))))))) 993 994(defun init-fortran-io () 995 "Initialize the F2CL Fortran I/O subsystem to sensible defaults" 996 (clrhash *lun-hash*) 997 (setf (gethash 6 *lun-hash*) *standard-output*) 998 (setf (gethash 5 *lun-hash*) *standard-input*) 999 (setf (gethash t *lun-hash*) *standard-output*)) 1000 1001(defun close-fortran-io () 1002 "Close all F2CL Fortran units (except for standard output and input) 1003causing all pending operations to be flushed" 1004 (maphash #'(lambda (key val) 1005 (when (and (streamp val) (not (member key '(5 6 t)))) 1006 (format t "Closing unit ~A: ~A~%" key val) 1007 (close val))) 1008 *lun-hash*)) 1009 1010(defun %open-file (&key unit file status access form recl blank) 1011 (declare (ignore unit)) 1012 ;; We should also check for values of form that we don't support. 1013 (when recl 1014 (error "F2CL-LIB does not support record lengths")) 1015 (when blank 1016 (error "F2CL-LIB does not support any BLANK mode for files")) 1017 (when (and access (not (string-equal "sequential" 1018 (string-right-trim " " access)))) 1019 (error "F2CL-LIB does not support ACCESS mode ~S" access)) 1020 (when (and form (not (string-equal "unformatted" 1021 (string-right-trim " " form)))) 1022 (error "F2CL-LIB does not support FORM ~S" form)) 1023 (let ((s (and status (string-right-trim " " status)))) 1024 (finish-output) 1025 (cond ((or (null s) (string-equal s "unknown")) 1026 (open file :direction :io :if-exists :supersede 1027 :if-does-not-exist :create)) 1028 ((string-equal s "old") 1029 (open file :direction :io :if-does-not-exist nil :if-exists :overwrite)) 1030 ((string-equal s "new") 1031 (open file :direction :io :if-exists nil)) 1032 (t 1033 (error "F2CL-LIB does not support this mode for OPEN: ~S~%" 1034 s))))) 1035 1036(defmacro open-file (&key unit iostat err file status access form recl blank) 1037 (let ((result (gensym))) 1038 `(prog ((,result (%open-file :unit ,unit :file ,file :status ,status 1039 :access ,access :form ,form :recl ,recl :blank ,blank))) 1040 (when ,result 1041 (setf (gethash ,unit *lun-hash*) ,result)) 1042 ,(if err `(unless ,result (go ,(f2cl-lib::make-label err)))) 1043 ,(if iostat `(setf ,iostat (if ,result 0 1)))))) 1044 1045(defun %rewind (unit) 1046 (file-position (lun->stream unit) :start)) 1047 1048(defmacro rewind (&key unit iostat err) 1049 (let ((result (gensym))) 1050 `(prog ((,result (%rewind ,unit))) 1051 (declare (ignorable ,result)) 1052 ,(if err `(unless ,result (go ,(f2cl-lib::make-label err)))) 1053 ,(if iostat `(setf ,iostat (if ,result 0 1)))))) 1054 1055 1056(defun %close (&key unit status) 1057 (when status 1058 (error "F2CL-LIB does not support STATUS")) 1059 (cl:close (lun->stream unit))) 1060 1061(defmacro close$ (&key unit iostat err status) 1062 (let ((result (gensym))) 1063 `(prog ((,result (%close :unit ,unit :status ,status))) 1064 (declare (ignorable ,result)) 1065 ,(if err `(unless ,result (go ,(f2cl-lib::make-label err)))) 1066 ,(if iostat `(setf ,iostat (if ,result 0 1)))))) 1067 1068#-gcl 1069(declaim (ftype (function (t) stream) lun->stream)) 1070 1071(defmacro fformat (dest-lun format-cilist &rest args) 1072 (let ((stream (gensym))) 1073 `(let ((,stream (lun->stream ,dest-lun))) 1074 (execute-format-main ,stream ',format-cilist ,@args) 1075 ,@(unless (or (eq t dest-lun) (numberp dest-lun)) 1076 `((when (stringp ,dest-lun) 1077 (replace ,dest-lun (get-output-stream-string ,stream)))))))) 1078 1079(defun execute-format (top stream format arg-list) 1080 (do ((formats format (if (and top (null formats)) 1081 format 1082 (rest formats)))) 1083 ((or (null arg-list) 1084 (and (not top) 1085 (null formats))) 1086 #+nil 1087 (progn 1088 (format t "~&end formats = ~S~%" formats) 1089 (format t "~&end arg-list = ~S~%" arg-list)) 1090 (do ((more formats (rest more))) 1091 ((not (stringp (first more)))) 1092 (format stream (first more))) 1093 arg-list) 1094 1095 (when (null formats) 1096 ;; We're out of formats but not arguments. I think Fortran says 1097 ;; we should start over at the last repeat spec. So we look 1098 ;; over all the formats until we find the first number. That 1099 ;; means it's a repeat spec. 1100 ;; 1101 ;; This is probably wrong for complicated format statements. 1102 (do ((f format (cdr f)) 1103 (last-rep nil)) 1104 ((null f) 1105 (setf formats last-rep)) 1106 (when (or (eq (car f) t) 1107 (numberp (car f))) 1108 (setf last-rep f))) 1109 1110 (when (null formats) 1111 ;; Now what? We couldn't find a repeat spec, so should we 1112 ;; just start over? 1113 (setf formats format))) 1114 #+nil 1115 (let ((*print-circle* t)) 1116 (format t "~&arg-list = ~S~%" arg-list) 1117 (format t "~&formats = ~S~%" formats)) 1118 (cond ((listp (first formats)) 1119 (format stream (caar formats) (pop arg-list))) 1120 ((eq (first formats) #\:) 1121 ;; Terminate control if there are no more items 1122 (when (null arg-list) 1123 (return-from execute-format))) 1124 ((numberp (first formats)) 1125 ;; Repeat a group some fixed number of times 1126 (dotimes (k (first formats)) 1127 ;;(format t "k = ~A, format = ~S~%" k (second formats)) 1128 (setf arg-list 1129 (execute-format nil stream (second formats) arg-list)) 1130 ;; Gotta exit if we're out of arguments to print! 1131 (unless arg-list 1132 (return))) 1133 (setf formats (rest formats)) 1134 ;; Output a newline after the repeat (I think Fortran says this) 1135 ;;(format stream "~&") 1136 ;;(format t " cont with format = ~S~%" formats) 1137 ) 1138 ((eq (first formats) t) 1139 ;; Repeat "forever" (until we run out of data) 1140 (loop while arg-list do 1141 (setf arg-list 1142 (execute-format nil stream (second formats) arg-list)) 1143 ;; Output a newline after the repeat (I think Fortran says this) 1144 (format stream "~%"))) 1145 (t 1146 (format stream (car formats)))))) 1147 1148(defun flatten-list (x) 1149 (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'. 1150 (cond ((null x) r) 1151 ((atom x) 1152 (cons x r)) 1153 (t (flatten-helper (car x) 1154 (flatten-helper (cdr x) r)))))) 1155 (flatten-helper x nil))) 1156 1157;; Fortran G format, roughly. We use ~F for numbers "near" 1, and use 1158;; ~E otherwise. 1159;; 1160;; Note that g77 seems to use an exponent marker of E for single and 1161;; double floats, but Sun Fortran uses E and D. I think I like E and 1162;; D to distinguish between them. Also note that g77 uses just enough 1163;; digits for the numbers, but Sun Fortran seems to specify the number 1164;; of printed digits to be 16 or so. Thus 1.0 is "1.0" with g77, but 1165;; "1.0000000000000" with Sun Fortran. I like g77's style better. 1166(defun fortran-format-g (stream arg colon-p at-p &rest args) 1167 (declare (ignore colon-p at-p args)) 1168 (let* ((marker (typecase arg 1169 (single-float "E") 1170 (double-float "D"))) 1171 (a (abs arg)) 1172 ;; g77 uses limits 1d-4 and 1d9. Sun Fortran uses 1 and 1173 ;; 1d15. 1174 (format-string (if (or (zerop a) 1175 (and (>= a 1d-4) 1176 (< a 1d9))) 1177 "~F" 1178 (concatenate 'string "~,,2,,,,'" 1179 marker 1180 "E")))) 1181 (format stream format-string arg))) 1182 1183;; Output objects in Fortran style, roughly. This basically means 1184;; complex numbers are printed as "(<re>, <im>)", floats use 1185;; FORTRAN-FORMAT-G, integers use ~D, strings are printed as is, and 1186;; T/NIL become "T" or "F". 1187(defun fortran-format (stream arg colon-p at-p &rest args) 1188 (declare (ignore colon-p at-p args)) 1189 (etypecase arg 1190 (complex 1191 #-gcl 1192 (format stream "(~/f2cl-lib::fortran-format-g/, ~/f2cl-lib::fortran-format-g/)" 1193 (realpart arg) (imagpart arg)) 1194 #+gcl 1195 (progn 1196 (fortran-format-g stream (realpart arg) nil nil) 1197 (fortran-format-g stream (imagpart arg) nil nil))) 1198 (float 1199 #-gcl 1200 (format stream " ~/f2cl-lib::fortran-format-g/" arg) 1201 #+gcl 1202 (fortran-format-g stream arg nil nil)) 1203 (integer 1204 (format stream " ~D" arg)) 1205 (string 1206 (format stream "~A" arg)) 1207 ((member t nil) 1208 (format stream (if arg "T " "F "))))) 1209 1210(defun execute-format-main (stream format &rest args) 1211 (cond 1212 ((eq format :list-directed) 1213 ;; This prints out the args separated by spaces and puts a line 1214 ;; break after about 80 columns. 1215 (format stream "~& ~{~<~%~1,81:;~?~>~^~}~%" 1216 (let (pars) 1217 (dolist (v args) 1218 ;; Some special cases. Let FORTRAN-FORMAT handle 1219 ;; most cases, except strings, which we just print 1220 ;; out ourselves. Lists (from implied-do loops) and 1221 ;; arrays use FORTRAN-FORMAT for each element. 1222 (typecase v 1223 (string 1224 (push "~A" pars) 1225 (push (list v) pars)) 1226 (cons 1227 (dolist (item v) 1228 #-gcl 1229 (progn 1230 (push "~/f2cl-lib::fortran-format/" pars) 1231 (push (list item) pars)) 1232 (progn 1233 (push "~A" pars) 1234 (push (fortran-format nil item nil nil) pars)))) 1235 (array 1236 (dotimes (k (length v)) 1237 #-gcl 1238 (progn 1239 (push "~/f2cl-lib::fortran-format/" pars) 1240 (push (list (aref v k)) pars)) 1241 #+gcl 1242 (progn 1243 (push "~A" pars) 1244 (push (fortran-format nil (list (aref v k)) nil nil) 1245 pars)))) 1246 (t 1247 #-gcl 1248 (progn 1249 (push "~/f2cl-lib::fortran-format/" pars) 1250 (push (list v) pars)) 1251 #+gcl 1252 (progn 1253 (push "~A" pars) 1254 (push (fortran-format nil (list v) nil nil) pars))))) 1255 ;;(format t "~S~%" (reverse pars)) 1256 (nreverse pars)))) 1257 (t 1258 (let ((format-list (copy-tree format)) 1259 (arg-list 1260 (apply #'append 1261 (map 'list #'(lambda (x) 1262 (cond ((bigfloat:numberp x) 1263 (list x)) 1264 ((stringp x) 1265 (list x)) 1266 ((member x '(t nil)) 1267 ;; Convert T and NIL to :T 1268 ;; and :F so we print out T 1269 ;; and F, respectively. 1270 (case x 1271 ((t) 1272 (list :t)) 1273 ((nil) 1274 (list :f)) 1275 (t 1276 (list x)))) 1277 (t 1278 (coerce x 'list)))) 1279 args)))) 1280 (execute-format t stream format-list arg-list))))) 1281 1282 1283;; Initialize a multi-dimensional array of character strings. I think 1284;; we need to do it this way to appease some picky compilers (like 1285;; CMUCL). The initial-element is needed to get rid of a warning 1286;; about the default initial element not being a simple 1287;; string. However, this initializes all elements of the array to 1288;; exactly the same string, so we loop over the entire array contents 1289;; and initialize each element with a string of the appropriate 1290;; length. The string is initialized with #\Space because it seems 1291;; that's what Fortran initializes it to. 1292(defmacro f2cl-init-string (dims len &optional inits) 1293 (let ((init (gensym (symbol-name '#:array-))) 1294 (k (gensym (symbol-name '#:idx-)))) 1295 `(let ((,init (make-array (* ,@dims) 1296 :element-type `(simple-array character (,',@len)) 1297 :initial-element (make-string ,@len)))) 1298 (dotimes (,k (array-total-size ,init)) 1299 (setf (aref ,init ,k) 1300 (make-string ,@len :initial-element #\Space))) 1301 ,@(when inits 1302 (let ((k 0) 1303 (forms nil)) 1304 (dolist (val inits) 1305 (push `(replace (aref ,init ,k) ,val) forms) 1306 (incf k)) 1307 (nreverse forms))) 1308 1309 ,init))) 1310 1311;; This macro is supposed to set LHS to the RHS assuming that the LHS 1312;; is a Fortran CHARACTER type of length LEN. 1313;; 1314;; Currently, converts the RHS to the appropriate length string and 1315;; assigns it to the LHS. However, this can generate quite a bit of 1316;; garbage. We might want to be a bit smarter and use loops to 1317;; replace the individual characters of the LHS with the appropriate 1318;; characters from the RHS. 1319(defmacro f2cl-set-string (lhs rhs (string len)) 1320 (declare (ignore string)) 1321 (etypecase lhs 1322 (symbol 1323 ;; Assignment to a simple string. 1324 `(setf ,lhs (f2cl-string ,rhs ,len))) 1325 (list 1326 ;; Assignment to an array 1327 `(fset ,lhs (f2cl-string ,rhs ,len))))) 1328 1329(defun f2cl-string (string len) 1330 ;; Create a string of the desired length by either appending spaces 1331 ;; or truncating the string. 1332 (let ((slen (length string))) 1333 (cond ((= slen len) 1334 ;; Need to make a copy of the string, so we don't have 1335 ;; duplicated structure. 1336 (copy-seq string)) 1337 ((> slen len) 1338 ;; Truncate the string 1339 (subseq string 0 len)) 1340 (t 1341 ;; String is too short, so append some spaces 1342 (concatenate 'string string (make-string (- len slen) :initial-element #\Space)))))) 1343 1344 1345;;; Strictly speaking, this is not part of Fortran, but so many 1346;;; Fortran packages use these routines, we're going to add them here. 1347;;; They're much easier to implement in Lisp than in Fortran! 1348 1349;; 1350;; DOUBLE-PRECISION MACHINE CONSTANTS 1351;; D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. 1352;; D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. 1353;; D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. 1354;; D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. 1355;; D1MACH( 5) = LOG10(B) 1356;; 1357 1358(defun d1mach (i) 1359 (ecase i 1360 (1 least-positive-normalized-double-float) 1361 (2 most-positive-double-float) 1362 (3 #-(or gcl ecl) double-float-epsilon 1363 #+(or gcl ecl) (scale-float (float #X10000000000001 1d0) -105)) 1364 (4 (scale-float #-(or gcl ecl) double-float-epsilon 1365 #+(or gcl ecl) (scale-float (float #X10000000000001 1d0) -105) 1366 1)) 1367 (5 (log (float (float-radix 1d0) 1d0) 10d0)))) 1368 1369(defun r1mach (i) 1370 (ecase i 1371 (1 least-positive-normalized-single-float) 1372 (2 most-positive-single-float) 1373 (3 single-float-epsilon) 1374 (4 (scale-float single-float-epsilon 1)) 1375 (5 (log (float (float-radix 1f0)) 10f0)))) 1376 1377;; 1378;; This is the CMLIB version of I1MACH, the integer machine 1379;; constants subroutine originally developed for the PORT library. 1380;; 1381;; I1MACH can be used to obtain machine-dependent parameters 1382;; for the local machine environment. It is a function 1383;; subroutine with one (input) argument, and can be called 1384;; as follows, for example 1385;; 1386;; K = I1MACH(I) 1387;; 1388;; where I=1,...,16. The (output) value of K above is 1389;; determined by the (input) value of I. The results for 1390;; various values of I are discussed below. 1391;; 1392;; I/O unit numbers. 1393;; I1MACH( 1) = the standard input unit. 1394;; I1MACH( 2) = the standard output unit. 1395;; I1MACH( 3) = the standard punch unit. 1396;; I1MACH( 4) = the standard error message unit. 1397;; 1398;; Words. 1399;; I1MACH( 5) = the number of bits per integer storage unit. 1400;; I1MACH( 6) = the number of characters per integer storage unit. 1401;; 1402;; Integers. 1403;; assume integers are represented in the S-digit, base-A form 1404;; 1405;; sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) 1406;; 1407;; where 0 .LE. X(I) .LT. A for I=0,...,S-1. 1408;; I1MACH( 7) = A, the base. 1409;; I1MACH( 8) = S, the number of base-A digits. 1410;; I1MACH( 9) = A**S - 1, the largest magnitude. 1411;; 1412;; Floating-Point Numbers. 1413;; Assume floating-point numbers are represented in the T-digit, 1414;; base-B form 1415;; sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) 1416;; 1417;; where 0 .LE. X(I) .LT. B for I=1,...,T, 1418;; 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. 1419;; I1MACH(10) = B, the base. 1420;; 1421;; Single-Precision 1422;; I1MACH(11) = T, the number of base-B digits. 1423;; I1MACH(12) = EMIN, the smallest exponent E. 1424;; I1MACH(13) = EMAX, the largest exponent E. 1425;; 1426;; Double-Precision 1427;; I1MACH(14) = T, the number of base-B digits. 1428;; I1MACH(15) = EMIN, the smallest exponent E. 1429;; I1MACH(16) = EMAX, the largest exponent E. 1430(defun i1mach (i) 1431 (ecase i 1432 ;; What does the unit numbers really mean in Lisp? What do we 1433 ;; really want? 1434 1435 ;; The standard input unit 1436 (1 5) 1437 ;; The standard output unit 1438 (2 6) 1439 ;; The standard punch unit 1440 (3 6) 1441 ;; The standard error message unit 1442 (4 6) 1443 1444 ;; The number of bits per integer storage unit. What does this 1445 ;; mean in Lisp? 1446 (5 1447 (integer-length most-positive-fixnum)) 1448 ;; The number of characters per integer storage unit. What does 1449 ;; this mean in Lisp? 1450 (6 4) 1451 1452 ;; The base of integers. Assume 2's complement 1453 (7 2) 1454 ;; The number of base-2 digits. Assume fixnum size? 1455 (8 (integer-length most-positive-fixnum)) 1456 ;; The largest magnitude 1457 (9 most-positive-fixnum) 1458 1459 ;; Base of floating-poing representation 1460 (10 (float-radix 1f0)) 1461 ;; Number of digits in representation 1462 (11 (float-digits 1f0)) 1463 ;; Smallest exponent 1464 (12 (multiple-value-bind (frac exp sign) 1465 (decode-float least-positive-normalized-single-float) 1466 (declare (ignore frac sign)) 1467 (+ exp 1))) 1468 ;; Largest exponent 1469 (13 (multiple-value-bind (frac exp sign) 1470 (decode-float most-positive-single-float) 1471 (declare (ignore frac sign)) 1472 (- exp 1))) 1473 ;; Same for double-precision 1474 (14 (float-digits 1d0)) 1475 (15 (multiple-value-bind (frac exp sign) 1476 (decode-float least-positive-normalized-double-float) 1477 (declare (ignore frac sign)) 1478 (+ exp 1))) 1479 (16 (multiple-value-bind (frac exp sign) 1480 (decode-float most-positive-double-float) 1481 (declare (ignore frac sign)) 1482 (- exp 1))) 1483 )) 1484 1485;; F2cl cannot tell if a STOP statement is an error condition or just 1486;; the end of the program. So, by default, we signal a continuable 1487;; error. However, we give the user the option of silently returning 1488;; or not. 1489(defvar *stop-signals-error-p* nil 1490 "When non-NIL, STOP will signal an continuable error. Otherwise, STOP just returns") 1491 1492(defun stop (&optional arg) 1493 (when arg 1494 (format cl::*error-output* "~A~%" arg)) 1495 (when *stop-signals-error-p* 1496 (cerror "Continue anyway" "STOP reached"))) 1497 1498(defmacro f2cl-copy-seq (dst src dst-type src-type) 1499 (flet ((copy-error () 1500 (error "F2CL cannot copy arrays of element type ~A to ~A~%" 1501 src-type dst-type))) 1502 (cond ((subtypep dst-type 'float) 1503 ;; Copy to float array 1504 (cond ((subtypep src-type 'float) 1505 `(replace ,dst ,src)) 1506 ((subtypep src-type 'complex) 1507 ;; Copy complex to float by putting each real and 1508 ;; imaginary part into the float array, in order. 1509 (let ((idx (gensym "IDX-")) 1510 (el (gensym "EL-"))) 1511 `(loop for ,idx of-type fixnum from 0 by 2 below (length ,dst) 1512 for ,el of-type ,src-type across ,src 1513 do 1514 (progn 1515 (setf (aref ,dst ,idx) (realpart ,el)) 1516 (setf (aref ,dst (1+ ,idx)) (imagpart ,el)))))) 1517 (t 1518 (copy-error)))) 1519 ((subtypep dst-type 'complex) 1520 ;; Copy to complex array 1521 (cond ((subtypep src-type 'float) 1522 (let ((idx (gensym "IDX-")) 1523 (dst-idx (gensym "DST-IDX-"))) 1524 `(loop for ,idx of-type fixnum from 0 by 2 below (length ,src) 1525 for ,dst-idx of-type fixnum from 0 below (length ,dst) 1526 do 1527 (setf (aref ,dst ,dst-idx) (complex (aref ,src ,idx) 1528 (aref ,src (1+ ,idx))))))) 1529 ((subtypep src-type 'complex) 1530 `(replace ,dst ,src)) 1531 (t 1532 (copy-error)))) 1533 (t 1534 (copy-error))))) 1535 1536(defmacro make-compatible-seq (type array array-type) 1537 (let ((element-type (second type)) 1538 (array-type (second array-type))) 1539 (cond ((subtypep element-type 'float) 1540 (cond ((subtypep array-type 'complex) 1541 `(make-array (* 2 (length ,array)) :element-type ',element-type)) 1542 (t 1543 `(make-array (length ,array) :element-type ',element-type)))) 1544 ((subtypep element-type 'complex) 1545 (cond ((subtypep array-type 'complex) 1546 `(make-array (length ,array) :element-type ',element-type)) 1547 (t 1548 `(make-array (ceiling (length ,array) 2) :element-type ',element-type)))) 1549 (t 1550 (error "Don't know how to make an array with element-type ~A~%" element-type))))) 1551 1552 1553;;;------------------------------------------------------------------------- 1554;;; end of macros.l 1555;;; 1556;;; $Id: macros.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $ 1557;;; $Log$ 1558;;; Revision 1.117 2011/02/28 22:21:07 rtoy 1559;;; When opening an old file, we should set :if-exists to :overwrite to 1560;;; overwrite the file if written too. 1561;;; 1562;;; Revision 1.116 2011/02/20 20:51:04 rtoy 1563;;; Oops. STOP should signal an error if *STOP-SIGNALS-ERROR-P* is 1564;;; non-NIL. 1565;;; 1566;;; Revision 1.115 2010/12/28 00:06:52 rtoy 1567;;; Assert the type of the arg to fsqrt to be non-negative, excluding 1568;;; negative zero. 1569;;; 1570;;; Revision 1.114 2010/05/17 01:42:14 rtoy 1571;;; src/f2cl1.l: 1572;;; o Need to know the actual type when making a compatible sequence. 1573;;; o Convert plain integer type to integer4 types, which is what Fortran 1574;;; would do. We don't want general Lisp integer type. 1575;;; 1576;;; src/macros.l: 1577;;; o Change MAKE-COMPATIBLE-SEQ to be a macro. 1578;;; o Need to know the actual array type to create the correct type of 1579;;; sequence. 1580;;; 1581;;; Revision 1.113 2010/02/23 00:59:12 rtoy 1582;;; Support the Fortran capability of passing an array of one type 1583;;; to a routine expecting a different type. Currently only supports REAL 1584;;; and COMPLEX arrays (and their double precison versions). 1585;;; 1586;;; NOTES: 1587;;; o Update 1588;;; 1589;;; f2cl0.l: 1590;;; o Export new symbols f2cl-copy-seq and make-compatible-seq. 1591;;; 1592;;; f2cl1.l: 1593;;; o New variable *copy-array-parameter* for keeping track of the option 1594;;; for f2cl and f2cl-compile. 1595;;; o Update f2cl and f2cl-compile to recognize :copy-array-parameter. 1596;;; o Modify massage-arglist and generate-call-to-routine to handle the 1597;;; new :copy-array-parameter capability. 1598;;; 1599;;; f2cl5.l: 1600;;; o Fix issue where quoted elements were modified. They shouldn't be. 1601;;; o Fix issue where (array simple-float (*)) would get erroneously 1602;;; converted to (array simple-float (f2cl-lib:int-mul)). We want to 1603;;; leave bare * alone. 1604;;; 1605;;; macros.l: 1606;;; o New macro f2cl-copy-seq to generate code to copy a sequence 1607;;; appropriately. 1608;;; o New function to create a compatible array to support 1609;;; :copy-array-parameter. 1610;;; 1611;;; Revision 1.112 2009/01/08 12:57:19 rtoy 1612;;; f2cl0.l: 1613;;; o Export *STOP-SIGNALS-ERROR-P* 1614;;; 1615;;; macros.l: 1616;;; o Add *STOP-SIGNALS-ERROR-P* to allow user to control whether STOP 1617;;; signals a continuable error or not. Default is to signal the 1618;;; error. 1619;;; 1620;;; Revision 1.111 2009/01/07 21:50:16 rtoy 1621;;; Use the fast rint-* functions for CMUCL with sse2 support. 1622;;; 1623;;; Revision 1.110 2009/01/07 21:42:45 rtoy 1624;;; Gcl doesn't recognize :compile-toplevel and friends. Use old style. 1625;;; 1626;;; Revision 1.109 2009/01/07 21:34:41 rtoy 1627;;; Clean up junk: 1628;;; 1629;;; o Remove unused macro REXPT. 1630;;; o Remove duplicated function PROCESS-IMPLIED-DO. 1631;;; o Remove code that was commented out. 1632;;; 1633;;; Revision 1.108 2009/01/07 17:28:19 rtoy 1634;;; f2cl0.l: 1635;;; o Export new dfloat function, an alias for dble. 1636;;; o Merge some cleanups from Maxima. 1637;;; 1638;;; f2cl1.l: 1639;;; o Add dfloat to list of intrinsic functions. 1640;;; 1641;;; macros.l: 1642;;; o Merge some cleanups and fixes from Maxima. Mostly for gcl and ecl. 1643;;; o Add implementation of dfloat. 1644;;; 1645;;; Revision 1.107 2009/01/07 02:22:00 rtoy 1646;;; Need to quit a repeated group if we're out of arguments to print. 1647;;; This prevents us from repeatedly print newlines and other strings when 1648;;; the repetition is more than the number of arguments we have left. 1649;;; 1650;;; Revision 1.106 2008/09/15 15:27:36 rtoy 1651;;; Fix serious bug in aint. aint(x) for x an integer was returning x-1 1652;;; (for positive x). It should have returned x. 1653;;; 1654;;; Revision 1.105 2008/09/10 18:53:49 rtoy 1655;;; The case where the arg was negative or zero was mishandled and ended 1656;;; up being printed using ~E. Should have been ~F. 1657;;; 1658;;; Revision 1.104 2008/08/22 21:27:43 rtoy 1659;;; Oops. Forgot one place to conditionalize on gcl. 1660;;; 1661;;; Revision 1.103 2008/08/21 20:16:49 rtoy 1662;;; Gcl doesn' like ~/ format specifier, so rearrange things so we don't 1663;;; use it. (Should we just do the same for every one?) 1664;;; 1665;;; Revision 1.102 2008/03/26 13:19:52 rtoy 1666;;; Lazily initialize the lun-hash table. *lun-hash* starts as an empty 1667;;; hash-table, and lun->stream will initialize units 5, 6, and t as 1668;;; needed. 1669;;; 1670;;; Based on similar change in maxima to work around an issue with clisp 1671;;; where the predefined entries had closed streams. 1672;;; 1673;;; Revision 1.101 2008/03/08 12:49:08 rtoy 1674;;; Make :list-directed output be more like Fortran. There is quite a bit 1675;;; of variation between, say, g77 and Sun Fortran, so we pick something 1676;;; reasonably close. We have a mix of g77 and Sun Fortran output. Still 1677;;; needs some work. 1678;;; 1679;;; Revision 1.100 2008/03/07 23:15:01 rtoy 1680;;; Use ~? so we can control the format string to print out various 1681;;; objects for list-directed output. 1682;;; 1683;;; Revision 1.99 2008/03/06 21:20:41 rtoy 1684;;; Change the open mode from append to supersede. I think this makes 1685;;; more sense and seems to match g77 better. 1686;;; 1687;;; Revision 1.98 2008/03/06 20:04:10 rtoy 1688;;; Use ~G for list-directed I/O so that numbers come out reasonably. 1689;;; (F77 standard says E or F is used, depending on the magnitude of the 1690;;; number. The parameters for E and F are processer dependent as is the 1691;;; magnitude used to select between E or F. This is pretty close to how 1692;;; ~G works in Lisp.) 1693;;; 1694;;; Revision 1.97 2008/02/26 04:14:31 rtoy 1695;;; Explicitly check for T and NIL. 1696;;; 1697;;; Revision 1.96 2008/02/22 22:19:34 rtoy 1698;;; Use RCS Id as version. 1699;;; 1700;;; Revision 1.95 2008/02/22 22:13:18 rtoy 1701;;; o Add function F2CL-VERSION to get version info. 1702;;; o Add version string to each of the files so F2CL-VERSION can get the 1703;;; version info. The version string is basically the date of when the 1704;;; file was last checked in. 1705;;; 1706;;; Revision 1.94 2007/09/30 03:47:47 rtoy 1707;;; When we're out of formats, we restart with the last repeat spec. 1708;;; 1709;;; Revision 1.93 2007/09/28 22:01:08 rtoy 1710;;; First attempt at getting implied-do loops in data statements working 1711;;; with nested loops. 1712;;; 1713;;; f2cl1.l: 1714;;; o PARSE-DATA-IMPLIED-DO handles implied do loops even when the loops 1715;;; are nested. 1716;;; 1717;;; macros.l: 1718;;; o Update PROCESS-IMPLIED-DO to handle the new forms returned by 1719;;; PARSE-DATA-IMPLIED-DO. 1720;;; o Don't create constants out of the initializer since we use POP to 1721;;; access them one by one. 1722;;; o Minor tweak for list-directed output to allow a slightly longer line 1723;;; length. This matches what g77 produces for one simple test case. 1724;;; 1725;;; Revision 1.92 2007/09/28 20:26:13 rtoy 1726;;; o For REWIND and CLOSE$, declare the result as ignorable. 1727;;; o For list-directed output, don't print out strings as an array with 1728;;; spaces between each element. Strings should go out as strings. 1729;;; 1730;;; Revision 1.91 2007/09/28 15:41:14 rtoy 1731;;; Some cleanup for list-directed output: 1732;;; 1733;;; o Complex numbers should be printed in the form (r, i), not #c(r, i) 1734;;; o Arrays should print out only the elements instead of #(...). 1735;;; 1736;;; Revision 1.90 2007/09/28 05:00:58 rtoy 1737;;; To support multidimensional arrays in implied do loops better, we need 1738;;; to pass the entire array bounds, including upper and lower limits so 1739;;; that array indexing can work. 1740;;; 1741;;; f2cl5.l: 1742;;; o Find the entire array bounds. 1743;;; o Don't use make-declaration to get the array type. Explicitly look 1744;;; through *explicit_vble_decls* to find the type. (Are there other 1745;;; places we need to look?) 1746;;; 1747;;; macros.l: 1748;;; o Pass the entire list of array bounds to fref so we can handle 1749;;; multidimensional arrays. 1750;;; 1751;;; Revision 1.89 2007/09/27 14:56:39 rtoy 1752;;; When we run out of format specs, but there are still items to print, 1753;;; we go back and find the first repeat spec and start there. 1754;;; 1755;;; If there is no such thing, we just reuse the entire format spec. Not 1756;;; sure if this is right or if it's a bug. Maybe we should signal an 1757;;; error? 1758;;; 1759;;; Revision 1.88 2007/09/27 02:12:12 rtoy 1760;;; Support the L edit descriptor better. 1761;;; 1762;;; f2cl5.l: 1763;;; o Recognize the L descriptor and convert it to ~wA. 1764;;; 1765;;; macros.l: 1766;;; o Convert T and NIL to :T and :F, respectively. When coupled with ~A, 1767;;; this prints as T and F, as desired. 1768;;; 1769;;; Revision 1.87 2007/09/26 13:11:06 rtoy 1770;;; Remove the unused FOREVER parameter from EXECUTE-FORMAT. 1771;;; 1772;;; Revision 1.86 2007/09/26 13:10:15 rtoy 1773;;; Better list-directed output. 1774;;; 1775;;; f2cl5.l: 1776;;; o For list-directed output (format is *), return :list-directed to 1777;;; tell format that we're using list-directed output. (The previous 1778;;; scheme didn't really work well.) 1779;;; 1780;;; macros.l: 1781;;; o Add FLATTEN-LIST function 1782;;; o Don't output a newline for repeated items. We shouldn't do that. 1783;;; o Add support for :list-directed output. We recognize that and then 1784;;; just output all the args in a special way. 1785;;; 1786;;; Revision 1.85 2007/09/25 21:31:32 rtoy 1787;;; f2cl5.l: 1788;;; o Slight change in the format used for "*" format. 1789;;; o Change the repeatable descriptors to remove the repeat count if the 1790;;; count is 1. This was confusing the execute-format when determining 1791;;; when to print out newlines. This change applied to I, F, E, D, and 1792;;; G descriptors. 1793;;; 1794;;; macros.l: 1795;;; o Handle printing of "repeat forever" loops better. An extra arg to 1796;;; EXECUTE-FORMAT tells us to repeat "forever". 1797;;; o Output a newline at the end of a repeated specification. 1798;;; 1799;;; Revision 1.84 2007/09/25 18:46:42 rtoy 1800;;; For repeated descriptors, we were printing a new line after each item 1801;;; instead of after all items had been printed. Output new line only 1802;;; once, when we're done. 1803;;; 1804;;; Revision 1.83 2007/09/25 18:17:50 rtoy 1805;;; Oops. We should always process #\: and exit only if there is more 1806;;; args to process. 1807;;; 1808;;; Revision 1.82 2007/09/25 17:31:05 rtoy 1809;;; f2cl5.l: 1810;;; o Return #\: when encountering a colon edit descriptor. 1811;;; 1812;;; macros.l: 1813;;; o Recognize #\: and terminate processing if there are no arguments 1814;;; left. 1815;;; 1816;;; Revision 1.81 2007/09/23 20:51:43 rtoy 1817;;; Previous checkin changed how character strings are initialized. 1818;;; Modify code accordingly. (This needs to be rethought and made less 1819;;; fragile.) 1820;;; 1821;;; Revision 1.80 2007/09/21 17:45:13 rtoy 1822;;; INDEX was calling SEARCH with the arguments in the wrong order. 1823;;; 1824;;; Revision 1.79 2007/09/20 21:27:12 rtoy 1825;;; Was not handling atoms correctly. This needs more work. 1826;;; 1827;;; Revision 1.78 2007/09/20 17:38:25 rtoy 1828;;; In ARRAY-INITIALIZE, we can't make a literal list of the data because 1829;;; the data might not be literal. (That is, the data might be constants 1830;;; from a parameter statement.) 1831;;; 1832;;; Revision 1.77 2007/06/18 15:50:16 rtoy 1833;;; Bug [ 1709300 ] unused key parameters 1834;;; 1835;;; o In %open-file, ignore UNIT, and produce an error if FORM is UNFORMATTED 1836;;; o In %close, produce an error if STATUS is specified. 1837;;; 1838;;; Revision 1.76 2006/12/01 04:23:43 rtoy 1839;;; Minor cleanups 1840;;; 1841;;; src/f2cl0.l: 1842;;; o Cosmetic changes 1843;;; 1844;;; src/macros.l: 1845;;; o Make code work with "modern"-mode lisps. (Ported from maxima.) 1846;;; 1847;;; Revision 1.75 2006/11/28 19:06:18 rtoy 1848;;; o Make sure the second arg to FSET-STRING is a string. 1849;;; o FCHAR was using the wrong function. 1850;;; o Cleanup FFORMAT so there are no compiler warnings about REPLACE 1851;;; being called on constant data. (This is probably a compiler bug in 1852;;; CMUCL, but we should get rid of the stuff ourselves, anyway, instead 1853;;; of depending on the compiler to do it for us.) 1854;;; 1855;;; Revision 1.74 2006/11/27 19:09:51 rtoy 1856;;; In some places in LAPACK, an array slice is taken where the slice 1857;;; exceeds the bounds of the array. However, the array is never 1858;;; accessed. What are we to do? We could modify the LAPACK routines 1859;;; (everywhere!) to check for this, or we can silently make array-slice 1860;;; make a 0-element array. If the array is then accessed, we should get 1861;;; an error at the point of access, not the point of creation. 1862;;; 1863;;; Revision 1.73 2006/11/21 22:05:03 rtoy 1864;;; Fix ichar to accept either a real character or (more likely) a 1865;;; string. 1866;;; 1867;;; Revision 1.72 2006/11/21 18:21:37 rtoy 1868;;; o Add CDABS and DCONJG functions. 1869;;; o Add some type declarations for DIMAG 1870;;; 1871;;; Revision 1.71 2006/05/02 22:12:02 rtoy 1872;;; src/f2cl5.l: 1873;;; o Try to make better declarations for variables defined in parameter 1874;;; statements. We'll declare them as (double-float 42d0 42d0) if the 1875;;; parameter was initialized to 42d0. 1876;;; o MAKE-DECLARATION updated to take an extra keyword argument to 1877;;; indicate if this is a parameter variable and to give the initial 1878;;; value of the parameter so we can make the appropriate declaration. 1879;;; o When initializing simple variables in data statements, try to bind 1880;;; the variable with the initial value instead binding a default 0 zero 1881;;; and setq'ing it later. 1882;;; 1883;;; src/macros.l: 1884;;; o Change DEFTYPE for INTEGER4 to allow parameters so we can specify 1885;;; tight bounds if desired. 1886;;; 1887;;; Revision 1.70 2006/05/01 17:40:05 rtoy 1888;;; Change STOP to produce a continuable error instead of an error so that 1889;;; we can continue from the STOP statement, if we choose to. It's not 1890;;; necessarily an error in a converted program to reach a STOP statement. 1891;;; 1892;;; Revision 1.69 2006/04/27 17:44:01 rtoy 1893;;; src/f2cl0.l: 1894;;; o Export dimag, dcmplx, zsqrt 1895;;; 1896;;; src/f2cl1.l: 1897;;; o Add dcmplx, dimag, and zsqrt to the list of intrinsic function 1898;;; names. 1899;;; o When parsing "implicit none" statements, we don't modify 1900;;; *IMPLICIT_VBLE_DECLS*. I don't think it's needed and it can cause 1901;;; errors later on because :none is not a Lisp type. 1902;;; 1903;;; src/f2cl5.l: 1904;;; o Tell GET-FUN-ARG-TYPE about the result type of dcmplx, dsqrt, the 1905;;; complex*8 and complex*16 special functions. 1906;;; o ABS is an allowed lisp name. This gets rid of the spurious ABS$ 1907;;; local variable whenever we use the ABS function. 1908;;; 1909;;; src/macros.l: 1910;;; o Add implementations of dcmplx, dimag, and zsqrt. (We need to add 1911;;; more, I think.) 1912;;; 1913;;; Revision 1.68 2006/01/12 01:33:32 rtoy 1914;;; If status is not given or unknown, create the file if it doesn't 1915;;; exist. 1916;;; 1917;;; Revision 1.67 2006/01/11 22:57:58 rtoy 1918;;; Add rudimentary support for opening files and reading from files. 1919;;; 1920;;; src/f2cl1.l: 1921;;; o Recognize and handle open, rewind, and close statements. 1922;;; 1923;;; src/f2cl5.l: 1924;;; o Update parser for read to handle unit numbers. Rudimentary support 1925;;; for implied-do lists too. 1926;;; o Add parser for open, rewind, and close statements. 1927;;; 1928;;; src/macros.l: 1929;;; o Add functions and macros to handle opening, rewinding, 1930;;; and closing files. Needs more work still. 1931;;; 1932;;; Revision 1.66 2006/01/09 03:08:13 rtoy 1933;;; src/f2cl1.l: 1934;;; o Translate a Fortran STOP to be the stop function. Was just 1935;;; returning NIL, and this doesn't work so well. 1936;;; 1937;;; src/macros.l: 1938;;; o Add STOP function. It prints out the any arg, and then signals an 1939;;; error. 1940;;; 1941;;; Revision 1.65 2006/01/09 00:37:43 rtoy 1942;;; src/f2cl5.l: 1943;;; o When looking for initializers, don't just remove initializers when 1944;;; the array is not a 1-D array. Keep them, and return a second value 1945;;; indicating if the array is 1-D or not. 1946;;; o MAKE-CHAR-DECL was not properly declaring and initializing 2-D 1947;;; arrays as 1-D arrays like we're supposed to. Compute the total size 1948;;; of the array if we can. 1949;;; 1950;;; src/macros.l: 1951;;; o F2CL-INIT-STRING needs to make a 1-D array, even if the string array 1952;;; is multi-dimensional. 1953;;; 1954;;; Revision 1.64 2006/01/04 17:53:40 rtoy 1955;;; We were not correctly processing initialization of string arrays in 1956;;; data statements. 1957;;; 1958;;; src/f2cl1.l: 1959;;; o In PARSE-DATA1, return the entire list of initializers instead of 1960;;; just the first, in case we have an array of initializers. 1961;;; 1962;;; src/f2cl5.l: 1963;;; o In MERGE-DATA-AND-SAVE-INITS, we need to recognize the 1964;;; initialization of strings and such. We don't do anything special 1965;;; right now, like we do for arrays of numbers. 1966;;; o In INSERT-DECLARATIONS, we need to handle the case of REPLACE in the 1967;;; *data-init*'s. We assume it's been handled somewhere else, so 1968;;; there's nothing to do here. 1969;;; 1970;;; Revision 1.63 2005/05/19 15:06:24 rtoy 1971;;; Oops. make-label is in the f2cl-lib package. 1972;;; 1973;;; Revision 1.62 2005/05/16 15:50:25 rtoy 1974;;; o Replace single semicolons with multiple semicolons as appropriate. 1975;;; o GCL apparently doesn't like some declarations, so comment them out 1976;;; for GCL. 1977;;; o GCL doesn't like the defparameter for *lun-hash*. 1978;;; o GCL doesn't seem to have least-positive-normalized-double-float, so 1979;;; make it the same as least-positive-double-float. Likewise for 1980;;; single-float. 1981;;; 1982;;; These changes come from maxima. 1983;;; 1984;;; Revision 1.61 2005/03/28 20:38:18 rtoy 1985;;; Make strings with an element-type of character instead of base-char, 1986;;; in case the Lisp implementation has unicode support. 1987;;; 1988;;; Revision 1.60 2004/09/01 14:17:57 rtoy 1989;;; atan2 takes single-float args, not double-float. 1990;;; 1991;;; Revision 1.59 2004/08/14 22:29:16 marcoxa 1992;;; Added an EVAL-WHEN to silence the LW compiler. 1993;;; 1994;;; Revision 1.58 2004/08/14 04:17:45 rtoy 1995;;; Need a definition for MAKE-LABEL. 1996;;; 1997;;; Revision 1.57 2003/11/23 14:10:11 rtoy 1998;;; FDO should not call function that are not in the F2CL-LIB package. 1999;;; Macros.l should be self-contained. 2000;;; 2001;;; Revision 1.56 2003/11/13 05:37:11 rtoy 2002;;; Add macro WITH-MULTI-ARRAY-DATA. Basically like WITH-ARRAY-DATA, but 2003;;; takes a list of array info so we don't get deeply nested code when 2004;;; there are lots of arrays. 2005;;; 2006;;; Keep WITH-ARRAY-DATA around for backward compatibility. 2007;;; 2008;;; Revision 1.55 2003/11/12 05:33:22 rtoy 2009;;; Macro to handle assigned gotos was wrong. Fix it. 2010;;; 2011;;; Revision 1.54 2003/09/25 03:43:43 rtoy 2012;;; Need to check for reserved names in the fdo macro. (I think.) 2013;;; 2014;;; Revision 1.53 2003/01/07 18:44:52 rtoy 2015;;; Add new implementations of aint. Speeds up mpnorm by a factor of 5 on 2016;;; CMUCL/sparc! 2017;;; 2018;;; Revision 1.52 2002/09/13 17:50:19 rtoy 2019;;; From Douglas Crosher: 2020;;; 2021;;; o Make this work with lower-case Lisps 2022;;; o Fix a few typos 2023;;; o Make a safer fortran reader. 2024;;; 2025;;; Revision 1.51 2002/06/30 13:08:51 rtoy 2026;;; Add some declarations to AINT so that CMUCL can completely inline the 2027;;; call to ftruncate. 2028;;; 2029;;; Revision 1.50 2002/05/05 23:41:17 rtoy 2030;;; Typo: extra paren. 2031;;; 2032;;; Revision 1.49 2002/05/05 23:38:47 rtoy 2033;;; The int-sub macro didn't handle things like (- 3 m m) correctly. It 2034;;; was returning (- 3 (- m m)) instead of (- (- 3 m) m)! 2035;;; 2036;;; Revision 1.48 2002/05/03 17:48:06 rtoy 2037;;; GCL doesn't have least-positive-normalized-{single/double}-float, so 2038;;; use just least-positive-{single/double}-float. 2039;;; 2040;;; Revision 1.47 2002/05/03 17:44:36 rtoy 2041;;; Replace row-major-aref with just aref because we don't need it and 2042;;; because gcl doesn't have it. 2043;;; 2044;;; Revision 1.46 2002/03/19 02:23:09 rtoy 2045;;; According to the rules of Fortran, the initializers in a DATA 2046;;; statement are supposed to be converted to match the type of the 2047;;; variable that is being initialized. Make it so by passing the 2048;;; variable type to the macro DATA-IMPLIED-DO so that the conversion can 2049;;; be done. 2050;;; 2051;;; Revision 1.45 2002/03/18 23:34:16 rtoy 2052;;; Was not correctly handling some implied do loops containing multiple 2053;;; variables in the loop in data statements. Fix that and clean up some 2054;;; of the processing. (Should probably do this kind of work in the f2cl 2055;;; compiler instead of at runtime, but it's only done once at runtime, so 2056;;; it's not a big deal.) 2057;;; 2058;;; Revision 1.44 2002/03/11 16:44:00 rtoy 2059;;; o Remove an extra paren. 2060;;; o Indent FIND-ARRAY-DATA better. 2061;;; o Declare the iteration count to be of type INTEGER4. 2062;;; o Added macros INT-ADD, INT-SUB, INT-MUL to tell the compiler that the 2063;;; integer operation can't overflow. (First try.) 2064;;; o Tell the compiler that the result of truncate is an INTEGER4 in INT. 2065;;; 2066;;; Revision 1.43 2002/03/06 23:07:19 rtoy 2067;;; o Make INT return an integer4 type, not integer. 2068;;; o log10 was thinking it could generate complex result, but that's not 2069;;; true. Declare the arg correctly so the compiler knows it can't. 2070;;; 2071;;; Revision 1.42 2002/03/06 03:21:16 rtoy 2072;;; o Speed up FIND-ARRAY-DATA a little by declaring the offset to be a 2073;;; fixnum, which it has to be since it's an index to an array. 2074;;; o Remove the truncate/ftruncate-towards-zero functions. 2075;;; o For INT, AINT, and friends, TRUNCATE and FTRUNCATE are the right 2076;;; functions we want to use. (Stupid me!) 2077;;; o Update/correct some random comments. 2078;;; 2079;;; Revision 1.41 2002/02/17 15:55:29 rtoy 2080;;; o For all array accessors, wrap the offset calculations with (the 2081;;; fixnum ...) since they have to be anyway. Speeds up calculations 2082;;; quite a bit. 2083;;; o FREF takes an additional optional OFFSET arg to specify an offset 2084;;; for the new array slicing method. 2085;;; o Added WITH-ARRAY-DATA and FIND-ARRAY-DATA to support the new 2086;;; array-slicing method. 2087;;; o For FDO, add (the integer4 ...) for loop index calculations. 2088;;; o Add some more assertions for ISIGN and LOG10 to help the compiler 2089;;; generate better code. 2090;;; 2091;;; Revision 1.40 2002/02/10 03:43:51 rtoy 2092;;; Partial support for WRITE statements writing to a string instead of 2093;;; logical unit. 2094;;; 2095;;; Revision 1.39 2002/02/09 15:59:26 rtoy 2096;;; o Add more and better comments 2097;;; o AINT was broken because it should accept any range of floats. 2098;;; o DIM and friends computed the wrong thing! 2099;;; o Change DPROD to convert to doubles first. 2100;;; o Some cleanup of MAX and MIN 2101;;; 2102;;; Revision 1.38 2002/02/08 23:38:36 rtoy 2103;;; Use ARRAY-TOTAL-SIZE to compute how many elements are in the slice 2104;;; instead of the f2cl declared/derived bounds so that we can dynamically 2105;;; change the size of the array. Useful for an array in a common block. 2106;;; 2107;;; Revision 1.37 2002/02/07 03:23:15 rtoy 2108;;; Add functions to initialize F2CL's Fortran I/O and to close all of 2109;;; F2CL's open units. 2110;;; 2111;;; Revision 1.36 2002/02/04 03:23:46 rtoy 2112;;; o Make *lun-hash* a defparameter instead of a defvar. 2113;;; o Fix up i1mach so that the unit numbers match *lun-hash*. 2114;;; 2115;;; Revision 1.35 2002/01/13 16:29:00 rtoy 2116;;; o This file is in the f2cl-lib package now 2117;;; o Deleted some unused code. 2118;;; o Moved *INTRINSIC-FUNCTION-NAMES* to f2cl1.l 2119;;; 2120;;; Revision 1.34 2002/01/06 23:11:04 rtoy 2121;;; o Rename *intrinsic_function_names* to use dashes. 2122;;; o Comment out some unused functions and macros. 2123;;; 2124;;; Revision 1.33 2001/04/30 15:38:12 rtoy 2125;;; Add a version of I1MACH. 2126;;; 2127;;; Revision 1.32 2001/04/26 17:49:19 rtoy 2128;;; o SIGN and DIM are Fortran generic instrinsics. Make it so. 2129;;; o Added D1MACH and R1MACH because they're very common in Fortran 2130;;; libraries. 2131;;; 2132;;; Revision 1.31 2001/02/26 15:38:23 rtoy 2133;;; Move *check-array-bounds* from f2cl1.l to macros.l since the generated 2134;;; code refers to it. Export this variable too. 2135;;; 2136;;; Revision 1.30 2000/08/30 17:00:42 rtoy 2137;;; o In EXECUTE-FORMAT, handle the case where the group is supposed to be 2138;;; repeated "forever" (as indicated by a repetition factor of T). 2139;;; o Remove some more unused code. 2140;;; 2141;;; Revision 1.29 2000/08/27 16:36:07 rtoy 2142;;; Clean up handling of format statements. Should handle many more 2143;;; formats correctly now. 2144;;; 2145;;; Revision 1.28 2000/08/07 19:00:47 rtoy 2146;;; Add type ARRAY-STRINGS to denote an array of strings. 2147;;; 2148;;; Revision 1.27 2000/08/03 13:45:53 rtoy 2149;;; Make FFORMAT1 handle lists that we get from implied do loops. 2150;;; 2151;;; The whole FFORMAT stuff needs to be rethought if we really want to 2152;;; support Fortran output. 2153;;; 2154;;; Revision 1.26 2000/08/01 22:10:41 rtoy 2155;;; o Try to make the Fortran functions to convert to integers work the 2156;;; way Fortran says they should. 2157;;; o Declaim most of the intrinsics as inline so we don't have an 2158;;; additional function call for simple things. 2159;;; o Add some compiler macros for Fortran max/min functions to call the 2160;;; Lisp max/min functions withouth using #'apply. 2161;;; o Try to declare the args to functions with branchs appropriately, 2162;;; even in the face of signed zeroes. 2163;;; 2164;;; Revision 1.25 2000/07/28 22:10:05 rtoy 2165;;; Remove unused var from ARRAY-SLICE. 2166;;; 2167;;; Revision 1.24 2000/07/28 17:09:13 rtoy 2168;;; o We are in the f2cl package now. 2169;;; o Remove the export expression. 2170;;; o // is now called F2CL-//, to prevent problems with the lisp variable 2171;;; //. 2172;;; o REAL is now called FREAL, to prevent problems with the lisp type 2173;;; REAL. 2174;;; 2175;;; Revision 1.23 2000/07/27 16:39:17 rtoy 2176;;; We want to be in the CL-USER package, not the USER package. 2177;;; 2178;;; Revision 1.22 2000/07/20 13:44:38 rtoy 2179;;; o Remove old fref macro 2180;;; o Add some comments 2181;;; o Add macro ARRAY-INITIALIZE to handle creating the appropriate for to 2182;;; give to make-array :initial-contents. 2183;;; 2184;;; Revision 1.21 2000/07/19 13:54:27 rtoy 2185;;; o Add the types ARRAY-DOUBLE-FLOAT, ARRAY-SINGLE-FLOAT, and 2186;;; ARRAY-INTEGER4. 2187;;; o All arrays are 1-D now to support slicing of Fortran arrays 2188;;; correctly. 2189;;; o All arrays are in column-major order just like Fortran (and the 2190;;; opposite of Lisp). This is to support slicing of arrays. Modified 2191;;; FREF to support this by taking an extra arg for the dimensions of 2192;;; the array. 2193;;; o Added macro ARRAY-SLICE to slice the array properly. 2194;;; o Optimized routine DMIN1 a bit. (Need to do that for more routines.) 2195;;; 2196;;; Revision 1.20 2000/07/14 15:50:59 rtoy 2197;;; Get rid of *dummy_var*. It's not used anymore. 2198;;; 2199;;; Revision 1.19 2000/07/13 16:55:34 rtoy 2200;;; To satisfy the Copyright statement, we have placed the RCS logs in 2201;;; each source file in f2cl. (Hope this satisfies the copyright.) 2202;;; 2203;;;----------------------------------------------------------------------------- 2204