Typo fixes
[scilab.git] / scilab / modules / core / src / fortran / typ2cod.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) INRIA
3 c
4 c This file must be used under the terms of the CeCILL.
5 c This source file is licensed as described in the file COPYING, which
6 c you should have received as part of this distribution.  The terms
7 c are also available at
8 c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt
9
10       subroutine typ2cod(il,name,n)
11 c     returns in name(1:n) the code associated with the type of the
12 c     variable that began in istk(il)
13
14       INCLUDE 'stack.h'
15       integer nmax
16       parameter (nmax=8)
17 c     following common defines the initial database of type names
18       integer maxtyp,nmmax
19       parameter (maxtyp=50,nmmax=200)
20       integer tp(maxtyp),ptr(maxtyp),ln(maxtyp),namrec(nmmax),ptmax
21 cDEC$ IF DEFINED (FORDLL)
22 cDEC$ ATTRIBUTES DLLIMPORT:: /typnams/
23 cDEC$ ENDIF
24       common /typnams/ tp,ptr,ln,namrec,ptmax
25       integer name(*)
26       integer iadr,sadr
27 c
28       iadr(l)=l+l-1
29       sadr(l)=(l/2)+1
30 c
31       itype=abs(istk(il))
32       if(itype.le.20) then
33 c     look for itype in predefined types
34          if(itype.eq.16.or.itype.eq.17) then
35             if(istk(il).lt.0) il=iadr(istk(il+1))
36             n1=istk(il+1)
37             iltyp=iadr(sadr(il+3+n1))
38             nlt=min(nlgh-3,istk(iltyp+5)-1)
39             iltyp=iltyp+5+istk(iltyp+1)*istk(iltyp+2)
40             n=min(nlt,nmax)
41             call icopy(n,istk(iltyp),1,name(1),1)
42             return
43          elseif(itype.eq.0) then
44             n=1
45             name(1)=0
46          else
47             n=ln(itype)
48             call icopy(n,namrec(ptr(itype)),1,name,1)
49          endif
50       else
51 c     look for itype in dynamically added types
52          it=20
53  10      it=it+1
54          if(it.gt.maxtyp) goto 9000
55          if(tp(it).ne.itype) goto 10
56          n=ln(it)
57          call icopy(n,namrec(ptr(it)),1,name,1)
58       endif
59 c
60       return
61  9000 continue
62       n=0
63       return
64       end
65
66       subroutine addtypename(typ,nam,ierr)
67       integer pos,typ,ierr
68       character*(*) nam
69 c
70 c     Copyright INRIA
71 c     following common defines the initial database of type names
72       integer maxtyp,nmmax
73       parameter (maxtyp=50,nmmax=200)
74       integer tp(maxtyp),ptr(maxtyp),ln(maxtyp),namrec(nmmax),ptmax
75 cDEC$ IF DEFINED (FORDLL)
76 cDEC$ ATTRIBUTES DLLIMPORT:: /typnams/
77 cDEC$ ENDIF
78       common /typnams/ tp,ptr,ln,namrec,ptmax
79       character*15 nam1
80 c
81       ierr=0
82 c
83       n=len(nam)
84       if(n.gt.0) then
85 c     add a type
86          if(typ.le.20) then
87             pos=typ
88             if(ln(pos).ne.0) then
89 c     .     check if new type is the same as old type
90                if(ln(pos).eq.len(nam)) then
91                   n=ln(pos)
92                   call cvstr(ln(pos),namrec(ptr(pos)),nam1,1)
93                   if(nam1(1:n).eq.nam(1:n)) return
94                endif
95                ierr=2
96                return
97             endif
98          else
99             pos=20
100  10         pos=pos+1
101             if(pos.gt.maxtyp) then
102                ierr=1
103                return
104             endif
105             if(ln(pos).ne.0) goto 10
106          endif
107          tp(pos)=typ
108          if(ptmax+n.gt.nmmax) then
109             ierr=3
110             return
111          endif
112
113          ln(pos)=n
114          ptr(pos)=ptmax
115          call cvstr(n,namrec(ptmax),nam,0)
116          ptmax=ptmax+n
117       else
118 c     suppress a type
119          if(typ.le.20) then
120             pos=typ
121             if(ln(pos).eq.0) return
122          else
123             pos=20
124  20         pos=pos+1
125             if(pos.gt.maxtyp) return
126             if(tp(pos).ne.typ) goto 20
127          endif
128          n=ln(pos)
129          ll=ptmax-(ptr(pos)+n)+1
130          call icopy(ll,namrec(ptr(pos)+n),1,namrec(ptr(pos)),1)
131          ptr(pos)=0
132          ln(pos)=0
133          ptmax=ptmax-n
134       endif
135       return
136       end