Changeset 1140:46c1f6a93b0d

Timestamp:

05/02/12 21:40:28 (13 months ago)

Author:

Raymond Toy <toy.raymond@…>

Branch:

default

Message:

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.

Location:

src

Files:

• f2cl1.l (modified) (3 diffs)
• f2cl5.l (modified) (4 diffs)

src/f2cl1.l

@@ -204 +204 @@
   (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))))
@@ -1076 +1078 @@
         (do-file)
         (do-output outport))))
-    
 
 (defun translate-and-write-subprog (prog-list outport output-path
@@ -1152 +1153 @@
        ;; 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))~%")

src/f2cl5.l

@@ -1440 +1440 @@
                                       (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)))
@@ -2554 +2557 @@
            ;;(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.
@@ -2565 +2568 @@
            ;; 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.
@@ -2572 +2575 @@
            ;;(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)))))))