Commit 34a34954 authored by Raymond Toy's avatar Raymond Toy

Do a better job of handling symbols that have the same name as

intrinsics but are not intrinsic functions.

src/f2cl1.l:
o Get rid of *default-intrinsic-function-names*, and revert
  *intrinsic-function-names* to its original definition.
o Add *non-intrinsic-function-names* to hold symbols that can't be
  intrinsics because they are in the formal argument list of a
  subprogram.
o Remove *declared-intrinsic-names*
o When fixing up symbols that should be from f2cl-lib package because
  they're intrinsic functions, skip over symbols in
  *non-intrinsic-function-names*.
o Check the subprogram arg list for symbols have the same name as
  intrinsics and save them on *non-intrinsic-function-names* because we
  know they can't be intrinsics.

src/f2cl2.l:
o When trying to ID an intrinsic function call, we have to skip over
  anything in *non-intrinsic-function-names* because we know they're not
  intrinsics.

src/f2cl5.l:
o Update check-reserved-lisp-names because we don't need to handle
  intrinsic function specially.  Any symbol that looks like an instrinsic
  is one, unless it also shows up in *non-intrinsic-function-names*.
  This means we don't append "$" to these symbols, and that we also don't
  spuriously create symbols that aren't used.
parent 5d0d98c5
......@@ -17,7 +17,7 @@
"Use (f2cl-version) instead")
(defparameter *f2cl1-version*
"$Id: f2cl1.l,v 505dc31bee3e 2013/03/26 03:32:16 toy $")
"$Id: f2cl1.l,v 95098eb54f13 2013/04/01 00:45:16 toy $")
;; Forward declarations.
(defvar *f2cl2-version*)
......@@ -40,7 +40,7 @@
f2cl-lib::*f2cl-macros-version*)))
(defparameter *default-intrinsic-function-names*
(defparameter *intrinsic-function-names*
'(int ifix idint real float sngl dble cmplx dcmplx ichar char aint dint
anint dnint nint idnint iabs abs dabs cabs mod amod dmod isign sign dsign
idim dim ddim dprod max max0 max1 amax1 dmax1 amax0 amax1 min min0 amin1 dmin1
......@@ -55,11 +55,12 @@
)
"A list of all the intrinsic functions in Fortran 77 (or 95)")
(defvar *intrinsic-function-names*
nil
"A list of all the recognized intrinsic functions in the current
subprogram. This list will change if the subprogram declares a
variable with the same name as an intrinsic.")
(defvar *non-intrinsic-function-names*
nil
"A list of all names that should not be recognized as an intrinsic
function. This consists of formal parameters to subprograms that
would other wise be recognized as an intrinsic and anything declared
as external.")
;;------------------------------------------------------------------------------
;; Define the Fortran types that we need. This MUST match the types
......@@ -135,7 +136,6 @@
*parsing-lhs*
;; List of statement labels in a subprogram
*statement-labels*
*declared-intrinsic-names*
)))
(defvar *common-blocks* (make-hash-table)
......@@ -992,9 +992,10 @@ correctly"
;; i1mach. So if the Fortran code declares these as external, we
;; remove them. This assumes that d1mach and friends really is the
;; standard SLATEC d1mach.
(let ((external-names (remove-if #'(lambda (s)
(member s '(d1mach r1mach i1mach)))
external-names)))
(let ((external-names (append (remove-if #'(lambda (s)
(member s '(d1mach r1mach i1mach)))
external-names)
*non-intrinsic-function-names*)))
(do-external-symbols (lib-sym :f2cl-lib)
(unless (member lib-sym external-names :test #'(lambda (a b)
(string-equal (symbol-name a)
......@@ -1096,8 +1097,6 @@ correctly"
; the list
; of do
; integers
;; Setup default list of intrinsic functions
(*intrinsic-function-names* (copy-list *default-intrinsic-function-names*))
fort-fun *external-function-names*
*undeclared_vbles* *declared_vbles* *implicit_vble_decls* *explicit_vble_decls*
*save_vbles* *key_params* *subprog_common_vars*
......@@ -1107,7 +1106,7 @@ correctly"
*parsing-lhs*
*equivalenced-vars*
*common_array_dims*
*declared-intrinsic-names*)
*non-intrinsic-function-names*)
(print-header outport declaim package options)
(setq fort-fun
......@@ -1595,11 +1594,17 @@ correctly"
nil
))
;; Like check-reserved-lisp-names, but if the name would match an intrinsic, add it to the list of non-intrinsic names
(defun check-subprogram-arg-names (x)
(when (member x *intrinsic-function-names*)
(push x *non-intrinsic-function-names*))
(check-reserved-lisp-names x))
; subroutine definition
(defun parse-subr-definition (bindings)
(prog (arg-list)
(setq *subprog_name* (check-reserved-lisp-names (variable-value '%name bindings)))
(setq arg-list (mapcar #'check-reserved-lisp-names
(setq arg-list (mapcar #'check-subprogram-arg-names
(remove '|,| (variable-value '%arg-list bindings))))
(setq *subprog-arglist* arg-list)
(return (list 'defun *subprog_name*
......@@ -1615,7 +1620,7 @@ correctly"
(list (list (convert-data-type (variable-value '%type bindings))
(list fun-name))))
(setq *subprog-arglist*
(mapcar #'check-reserved-lisp-names
(mapcar #'check-subprogram-arg-names
(remove '|,| (variable-value '%arg-list bindings))))
(setf *subprog_name* fun-name)
(return
......@@ -1627,7 +1632,7 @@ correctly"
(defun parse-fun-definition (bindings)
(setq *function-flag* t)
(setq *subprog-arglist*
(mapcar #'check-reserved-lisp-names
(mapcar #'check-subprogram-arg-names
(remove '|,| (variable-value '%arg-list bindings))))
(list 'defun
(setf *subprog_name*
......@@ -1745,14 +1750,10 @@ correctly"
(defun parse-declaration (x) ; x is the line
(setq *declared_vbles*
(append (mapcar #'(lambda (v)
#+nil
(when (member (first v) *intrinsic-function-names*)
(warn "~A is being declared but is also the name of an intrinsic function"
(first v)))
;; To handle this, check for reserved
;; names, and then remove this name from
;; the list of intrinsic function names.
(setf *intrinsic-function-names*
(remove (first v) *intrinsic-function-names*))
(check-reserved-lisp-names (car v)))
(list-split '|,|
(if (eq (cadr x) '*)
......@@ -2958,10 +2959,7 @@ correctly"
nil)
;; parse INTRINSIC f1, f2
;; by adding the function names to *declared-intrinsic-names*
(defun parse-intrinsic (x)
(setf *declared-intrinsic-names*
(append *declared-intrinsic-names* (remove '|,| (cdr x))))
nil)
;; parse EQUIVALENCE (x1,y1), (x2, y2), ...
......@@ -3396,7 +3394,7 @@ loop2
;;;-----------------------------------------------------------------------------
;;; end of f2cl1.l
;;;
;;; $Id: f2cl1.l,v 505dc31bee3e 2013/03/26 03:32:16 toy $
;;; $Id: f2cl1.l,v 95098eb54f13 2013/04/01 00:45:16 toy $
;;; $Log$
;;; Revision 1.222 2010/10/08 03:05:30 rtoy
;;; src/f2cl1.l:
......
......@@ -21,7 +21,7 @@
*functions-used*)))
(defparameter *f2cl2-version*
"$Id: f2cl2.l,v d3ff69a91f35 2013/03/17 18:00:06 toy $")
"$Id: f2cl2.l,v 95098eb54f13 2013/04/01 00:45:16 toy $")
;-----------------------------------------------------------------------------
; subst-splice substitutes the list b for the atom a in the list c via splicing
......@@ -302,6 +302,7 @@ Tag being parsed:| (cadr x))))
; intrinsic function call:
((and (symbolp (car l))
(listp (cadr l))
(not (member (car l) *non-intrinsic-function-names*))
(member (car l) *intrinsic-function-names*))
(cond ((not (null (cddr l)))
(princ-reset
......@@ -476,7 +477,7 @@ definition.| l) ))
;;;-----------------------------------------------------------------------------
;;; end of f2cl2.l
;;;
;;; $Id: f2cl2.l,v d3ff69a91f35 2013/03/17 18:00:06 toy $
;;; $Id: f2cl2.l,v 95098eb54f13 2013/04/01 00:45:16 toy $
;;; $Log$
;;; Revision 1.37 2008/02/22 22:19:33 rtoy
;;; Use RCS Id as version.
......
......@@ -50,7 +50,7 @@
(in-package :f2cl)
(defparameter *f2cl5-version*
"$Id: f2cl5.l,v 505dc31bee3e 2013/03/26 03:32:16 toy $")
"$Id: f2cl5.l,v 95098eb54f13 2013/04/01 00:45:16 toy $")
;; functions for setting up varaible declarations and initialisations
(eval-when (compile load eval)
......@@ -2757,20 +2757,11 @@
((or (and found-it
(not (eq access :internal))
(fboundp found-it))
(member x +reserved-lisp-names+)
(and (eq :external (nth-value 1 (find-symbol (symbol-name x) :f2cl-lib)))
(member x *default-intrinsic-function-names*)
(not (member x *declared-intrinsic-names*))))
(member x +reserved-lisp-names+))
;; We want to append "$" for certain cases to prevent
;; collisions. (Any character can be used. But we can't
;; prepend because f2cl wants to look at the first
;; character to determine the default variable type.)
;;
;; 1. External functions in the common-lisp package.
;;
;; 2. External symbols in the f2cl-lib package. But if
;; they're intrinsics and declared as intrinsics, we
;; don't need to.
(intern (concatenate 'string (string x) "$")))
(t
x))))
......@@ -3876,7 +3867,7 @@
;;;-----------------------------------------------------------------------------
;;; end of f2cl5.l
;;;
;;; $Id: f2cl5.l,v 505dc31bee3e 2013/03/26 03:32:16 toy $
;;; $Id: f2cl5.l,v 95098eb54f13 2013/04/01 00:45:16 toy $
;;; $Log$
;;; Revision 1.204 2010/02/23 05:21:30 rtoy
;;; Fix declaration for default integer type. Previously the type was
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment