scilab/modules/core/sci_gateway/fortran/sci_f_clear.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-en.txt
   9       subroutine intclear(fname)
  10       include 'stack.h'
  11 c
  12       parameter (nz3=nsiz-3,nz2=nsiz-2)
  13       character*(*) fname
  14       integer top0,id(nsiz)
  15       logical getsmat,checkval,checklhs
  16       integer iadr
  17       integer a, blank,percen,helps(nsiz)
  18
  19
  20       data a/10/,blank/40/,percen/56/
  21       data helps /353243448,673717273,nz2*673720360/
  22
  23       iadr(l)=l+l-1
  24
  25 c
  26       if(.not.checklhs(fname,1,1)) return
  27
  28       if(rhs.le.0) then
  29          if (macr.ne.0 .or. paus.ne.0) then
  30             if(rstk(pt-2).eq.909) then
  31 c     .     clear within an exec'd macro
  32                goto 01
  33             endif
  34 c     .     clear within a macro, an execstr, an exec or a pause
  35             k = lpt(1) - (13+nsiz)
  36             if(lin(k+7).ne.0.and.istk(lin(k+6)).eq.10) goto 02
  37 c     .     clear within a macro, an exec or a pause
  38             bot = min(bbot,lin(k+5))
  39             goto 02
  40          endif
  41
  42  01      continue
  43 c     .  clear all variable
  44
  45 c     .  preserve %help variable
  46          i1=bbot
  47          fin=-1
  48          call stackg(helps)
  49          if(err.gt.0) return
  50          if (fin.gt.0) i1=min(fin,i1)
  51
  52          fin=0
  53          call stackg(helps)
  54          if(err.gt.0) return
  55          ih=fin
  56
  57          fin=0
  58          is=fin
  59          bot = bbot
  60          if(ih.eq.-1) then
  61             call stackp(helps,0)
  62             if(err.gt.0) return
  63          endif
  64  02      top=top+1
  65          il = iadr(lstk(top))
  66          istk(il) = 0
  67          lstk(top+1) = lstk(top) + 1
  68          return
  69       endif
  70
  71       top0=top
  72       do 10 k=1,rhs
  73          if(.not.getsmat(fname,top0,top,m,n,1,1,lr,nlr)) return
  74          if(.not.checkval(fname,m*n,1)) return
  75          if(nlr.eq.0) then
  76             top=top-1
  77             goto 10
  78          endif
  79 c        . check for valid variable name
  80          do 05 i=0,nlr-1
  81             ic=abs(istk(lr+i))
  82             if((ic.gt.blank.and.(i.gt.0.and.ic.eq.percen)).or.
  83      $           (i.eq.0.and.ic.lt.a)) then
  84                err=rhs+1-k
  85                call error(248)
  86                return
  87             endif
  88  05      continue
  89          call namstr(id,istk(lr),nlr,0)
  90          il = iadr(lstk(top))
  91          istk(il) = 0
  92          lstk(top+1) = lstk(top) + 1
  93          rhs = 0
  94          call stackp(id,0)
  95          if (err .gt. 0.or.err1.gt.0) return
  96          fin = 1
  97  10   continue
  98       top=top+1
  99       il = iadr(lstk(top))
 100       istk(il) = 0
 101       lstk(top+1) = lstk(top) + 1
 102       end
 103