From aa6e6d0a40f9b0ff6889c2a2103a53f53edb4a36 Mon Sep 17 00:00:00 2001 From: Raymond Toy Date: Wed, 2 May 2012 21:40:28 -0700 Subject: [PATCH] Don't declare strings as (simple-array character). In general that's incorrect for literal strings because they can be base-strings or strings, depending on the implementation. (Ecl does this). Thus, just declare them as simple-strings which includes all string types. --- src/f2cl1.l | 13 +++++++------ src/f2cl5.l | 31 +++++++++++++++++-------------- 2 files changed, 24 insertions(+), 20 deletions(-) diff --git a/src/f2cl1.l b/src/f2cl1.l index 0a8a13a..8a3c7a6 100644 --- a/src/f2cl1.l +++ b/src/f2cl1.l @@ -17,7 +17,7 @@ "Use (f2cl-version) instead") (defparameter *f2cl1-version* - "$Id: f2cl1.l,v 2bc8b118fd29 2011/12/03 06:01:32 toy $") + "$Id: f2cl1.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $") ;; Forward declarations. (defvar *f2cl2-version*) @@ -203,9 +203,11 @@ incorrect, so use caution.") (defun relax-array-decl (decls) (flet ((relax-1 (decl) (cond ((and *relaxed-array-decls* (subtypep decl 'array)) - (destructuring-bind (a n l) + (destructuring-bind (a &optional n l) decl - `(,a ,n ,(mapcar (constantly '*) l)))) + (if (subtypep a 'string) + `(a ,(mapcar (constantly '*) l)) + `(,a ,n ,(mapcar (constantly '*) l))))) (t decl)))) (mapcar #'relax-1 decls))) @@ -1075,7 +1077,6 @@ correctly" (if *common-block-file* (do-file) (do-output outport)))) - (defun translate-and-write-subprog (prog-list outport output-path declaim package options) @@ -1151,7 +1152,7 @@ correctly" ;; functions, in case the Fortran code has declared them as ;; external. (setf fun (fixup-f2cl-lib fun (cons (cadr fort-fun) *external-function-names*))) - + (special-print fun outport) (format outport "~2&(in-package #-gcl #:cl-user #+gcl \"CL-USER\")~%#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))~%") (let* ((*package* (find-package '#:cl-user)) @@ -3350,7 +3351,7 @@ loop2 ;;;----------------------------------------------------------------------------- ;;; end of f2cl1.l ;;; -;;; $Id: f2cl1.l,v 2bc8b118fd29 2011/12/03 06:01:32 toy $ +;;; $Id: f2cl1.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $ ;;; $Log$ ;;; Revision 1.222 2010/10/08 03:05:30 rtoy ;;; src/f2cl1.l: diff --git a/src/f2cl5.l b/src/f2cl5.l index 90b45cf..7f0d6c2 100644 --- a/src/f2cl5.l +++ b/src/f2cl5.l @@ -50,7 +50,7 @@ (in-package :f2cl) (defparameter *f2cl5-version* - "$Id: f2cl5.l,v 2bc8b118fd29 2011/12/03 06:01:32 toy $") + "$Id: f2cl5.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $") ;; functions for setting up varaible declarations and initialisations (eval-when (compile load eval) @@ -1439,13 +1439,16 @@ (cond ((and (listp decl) (eq 'type (first decl)) (subtypep (second decl) 'array)) - (destructuring-bind (a n l) + (destructuring-bind (a &optional n l) (second decl) - `(type (,a ,n ,(mapcar #'(lambda (x) - (declare (ignore x)) - '*) - l)) - ,@(rest (rest decl))))) + (if (subtypep a 'string) + `(type (,a *) + ,@(rest (rest decl))) + `(type (,a ,n ,(mapcar #'(lambda (x) + (declare (ignore x)) + '*) + l)) + ,@(rest (rest decl)))))) (t decl))) (first formal-arg-decls))))) @@ -2553,8 +2556,8 @@ ;; scalar, no length spec. ;;(format t "scalar, no length spec = ~A~%" decl) (if (equal (cadr type) '(*)) - `(declare (type (simple-array character (*)) ,(car decl))) - `(declare (type (simple-array character (,(cadr type))) ,(car decl))))) + `(declare (type (simple-string) ,(car decl))) + `(declare (type (simple-string ,(cadr type)) ,(car decl))))) ((atom (cadr decl)) ;; scalar, length spec. ;;(format t "scalar, length spec = ~A~%" decl) @@ -2564,16 +2567,16 @@ ((equal (cadr decl) '(*)) ;; unspecified length spec ;;(format t "unspecified length spec = ~A~%" decl) - `(declare (type (simple-array character (*)) ,(car decl)))) + `(declare (type (simple-string) ,(car decl)))) (t ;; array, no length spec. ;;(format t "array, no length spec = ~A~%" decl) ;;(format t "type = ~S~%" type) ;;(format t "decl-bounds = ~S~%" (decl-bounds (rest decl))) `(declare (type (,*array-type* - (simple-array character ,(if (second type) - `(,(second type)) - '(*))) + (string ,(if (second type) + (second type) + '*)) ,(decl-bounds (rest decl))) ,(car decl))))))) (defun make-char-init (decl type &optional init) @@ -3858,7 +3861,7 @@ ;;;----------------------------------------------------------------------------- ;;; end of f2cl5.l ;;; -;;; $Id: f2cl5.l,v 2bc8b118fd29 2011/12/03 06:01:32 toy $ +;;; $Id: f2cl5.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $ ;;; $Log$ ;;; Revision 1.204 2010/02/23 05:21:30 rtoy ;;; Fix declaration for default integer type. Previously the type was -- GitLab