xpressn.c

ngspice又一个电子CAD仿真软件代码.功能更全

      Else
        pscopy(t,s,i+1, k-i-1); 
        err=evaluate( dico, q,t,0);
      EndIf
      i=k;
      If Not err Then /*insert number*/
        sadd(r,q)
      Else 
        err=message( dico,s)
      EndIf
    ElsIf c==Intro Then
      Inc(i);
      While (i<ls) And (s[i-1]<=' ') Do Inc(i) Done
      k=i;
      If s[k-1]=='(' Then /*sub-formula*/ 
        level=1;
        Repeat 
          Inc(k);
          If k>ls Then 
            d=chr(0) 
          Else 
            d=s[k-1] 
          EndIf
          If d=='(' Then 
            Inc(level) 
          ElsIf d==')' Then 
            Dec(level)
          EndIf
        Until (k>ls) Or ((d==')') And (level<=0)) EndRep
	If k>ls Then  
          err=message( dico,"Closing \")\" not found.");
        Else
	  pscopy(t,s,i+1, k-i-1); 
          err=evaluate( dico, q,t,0);
        EndIf
        i=k;
      Else /*simple identifier may also be string*/
        Repeat 
          Inc(k);
          If k>ls Then 
            d=chr(0) 
          Else 
            d=s[k-1] 
          EndIf
        Until (k>ls) Or (d<=' ') EndRep
	pscopy(t,s,i,k-i); 
        err=evaluate( dico, q,t,1);
        i=k-1;
      EndIf
      If Not err Then /*insert the number*/ 
        sadd(r,q)
      Else 
        message( dico,s)
      EndIf
    ElsIf c==Nodekey Then /*follows: a node keyword*/
      Repeat 
        Inc(i) 
      Until s[i-1]>' ' EndRep
      k=i;
      Repeat 
        Inc(k) 
      Until (k>ls) Or Not alfanum(s[k-1]) EndRep
      pscopy(q,s,i,k-i);
      nd=parsenode( Addr(dico->nodetab), q); 
      If Not spice3 Then 
        stri(nd,q) 
      EndIf; /* substitute by number */ 
      sadd(r,q);
      i=k-1;
    Else 
      If Not spice3 Then c=upcase(c) EndIf
      cadd(r,c); /*c<>Intro*/
    EndIf
  Done /*while*/
  return err;
EndFunc
#endif

/********* interface functions for spice3f5 extension ***********/

Intern
Proc compactfloatnb(Pchar v)
/* try to squeeze a floating pt format to 10 characters */ 
/* erase superfluous 000 digit streams before E */
/* bug: truncating, no rounding */ 
Begin
  short n,k, lex;
  Str(20,expo);
  n=cpos('E',v); /* if too long, try to delete digits */
  If n >3 Then
    pscopy(expo, v, n,length(v));
    lex= length(expo);
    k=n-2;  /* mantissa is 0...k */
    While (v[k]=='0') And (v[k-1]=='0') Do Dec(k) Done
    If (k+1+lex) > 10 Then k= 9-lex EndIf
    pscopy(v,v, 1,k+1); 
    sadd(v,expo);   
  EndIf
EndProc

Intern
Func short insertnumber(tdico *dico, short i, Pchar s, Pchar u)
/* insert u in string s in place of the next placeholder number */
Begin
  Str(40,v);
  Str(80,msg);
  Bool found;
  short ls, k; 
  long accu;
  ls= length(s);
  scopy(v,u);
  compactfloatnb(v);
  While length(v)<10 Do 
    cadd(v,' ') 
  Done
  If length(v)>10 Then 
    scopy(msg," insertnumber fails: "); 
    sadd(msg,u); 
    message( dico, msg) 
  EndIf
  found=False;
  While (Not found) And (i<ls) Do
    found= (s[i]=='1');
    k=0; accu=0;
    While found And (k<10) Do /* parse a 10-digit number */  
      found= num(s[i+k]);
      If found Then 
         accu= 10 * accu + s[i+k]- '0' 
      EndIf
      Inc(k)
    Done
    If found Then 
      accu=accu - 1000000000L; /* plausibility test */
      found= (accu>0) And (accu<2000)
    EndIf
    Inc(i)
  Done
  If found Then /* substitute at i-1 */
    Dec(i);
    For k=0; k<10; Inc(k) Do s[i+k]= v[k] Done
    i= i+10;
  Else 
    i= ls; 
    message( dico,"insertnumber: missing slot ");
  EndIf
  return i
EndFunc

Func Bool nupa_substitute( tdico *dico, Pchar s, Pchar r, Bool err)
/* s: pointer to original source line.
   r: pointer to result line, already heavily modified wrt s 
   anywhere we find a 10-char numstring in r, substitute it.
  bug: wont flag overflow!
*/
Begin
  short i,k,ls,level, nnest, ir;
  char c,d;
  Strbig(Llen, q);
  Strbig(Llen, t);
  i=0; 
  ls=length(s); 
  err=False; 
  ir=0;
  While (i<ls) And (Not err) Do
    Inc(i); c=s[i-1];
    If c==Pspice Then /* try pspice expression syntax */
      k=i; nnest=1;
      Repeat 
        Inc(k); d=s[k-1];
        If d=='{' Then 
          Inc(nnest) 
        ElsIf d=='}' Then 
          Dec(nnest) 
        EndIf
      Until (nnest==0) Or (d==0) EndRep
      If d==0 Then 
        err=message( dico,"Closing \"}\" not found.");
      Else
        pscopy(t,s,i+1, k-i-1); 
        err=evaluate( dico, q,t,0);
      EndIf
      i=k;
      If Not err Then
        ir= insertnumber(dico, ir, r,q)
      Else 
        err=message( dico, "Cannot compute substitute")
      EndIf
    ElsIf c==Intro Then
      Inc(i);
      While (i<ls) And (s[i-1]<=' ') Do Inc(i) Done
      k=i;
      If s[k-1]=='(' Then /*sub-formula*/ 
        level=1;
        Repeat 
          Inc(k);
          If k>ls Then 
            d=chr(0) 
          Else 
            d=s[k-1]
          EndIf
          If d=='(' Then 
            Inc(level) 
          ElsIf d==')' Then 
            Dec(level)
          EndIf
        Until (k>ls) Or ((d==')') And (level<=0)) EndRep
	If k>ls Then
          err=message( dico,"Closing \")\" not found.");
        Else
	  pscopy(t,s,i+1, k-i-1);
          err=evaluate( dico, q,t,0);
        EndIf
        i=k;
      Else /*simple identifier may also be string? */
        Repeat 
          Inc(k);
          If k>ls Then
            d=chr(0) 
          Else
            d=s[k-1]
          EndIf
        Until (k>ls) Or (d<=' ') EndRep
	pscopy(t,s,i,k-i); 
        err=evaluate( dico, q,t,1);
        i= k-1;
      EndIf
      If Not err Then
        ir= insertnumber(dico, ir, r,q)
      Else
        message( dico, "Cannot compute &(expression)")
      EndIf
    EndIf
  Done /*while*/
  return err
EndFunc

Intern
Func Byte getword(
 Pchar  s, Pchar t,
 Byte  after,
 short * pi)
/* isolate a word from s after position "after". return i= last read+1 */
Begin
  short i= *pi;
  short ls;
  Byte key;
  i=after;
  ls=length(s);
  Repeat
    Inc(i)
  Until (i>=ls) Or alfa(s[i-1]) EndRep
  scopy(t,"");
  While (i<=ls) And (alfa(s[i-1]) Or num(s[i-1])) Do
    cadd(t,upcase(s[i-1])); 
    Inc(i);
  Done
  If NotZ(t[0]) Then 
     key=keyword(keys,t) 
  Else
     key=0 
  EndIf
  *pi=i;
  return key;
EndFunc

Intern
Func char getexpress( Pchar s, Pchar t, short * pi)
/* returns expression-like string until next separator
 Input  i=position before expr, output  i=just after expr, on separator.
 returns tpe=='R' If numeric, 'S' If string only
*/
Begin
  short i= *pi; 
  short ia,ls,level;
  char c,d, tpe;
  Bool comment= False;
  ls=length(s);
  ia=i+1;
  While (ia<ls) And (s[ia-1]<=' ') Do
    Inc(ia)
  Done /*white space ? */
  If s[ia-1]=='\"' Then /*string constant*/
    Inc(ia); 
    i=ia;
    While (i<ls) And (s[i-1]!='\"') Do Inc(i) Done
    tpe='S';
    Repeat
      Inc(i)
    Until (i>ls) Or (s[i-1] >' ') EndRep
  Else
    If s[ia-1]=='{' Then Inc(ia) EndIf
    i= ia-1;
    Repeat 
      Inc(i); 
      If i>ls Then
        c=';' 
      Else
        c=s[i-1]
      EndIf
      If c=='(' Then /*sub-formula*/ 
        level=1;
        Repeat
          Inc(i);
          If i>ls Then
            d=Nul
          Else
            d=s[i-1]
          EndIf
          If d=='(' Then
            Inc(level)
          ElsIf d==')' Then
            Dec(level)
          EndIf
        Until (i>ls) Or ((d==')') And (level<=0)) EndRep
      EndIf
      /* buggy? */ If (c=='/') Or (c=='-') Then comment= (s[i]==c) EndIf 
    Until (cpos(c, ",;)}") >0)  Or comment EndRep /*legal separators*/
    tpe='R';
  EndIf
  pscopy(t,s,ia,i-ia); 
  If s[i-1]=='}' Then Inc(i) EndIf
  If tpe=='S' Then Inc(i) EndIf /* beyond quote */
  *pi=i; 
  return tpe;
EndFunc

Func Bool nupa_assignment( tdico *dico, Pchar  s, char mode)
/* is called for all 'Param' lines of the input file.
   is also called for the params: section of a subckt .
   mode='N' define new local variable, else global...
   bug: we cannot rely on the transformed line, must re-parse everything!
*/
Begin
/* s has the format: ident = expression; ident= expression ...  */
  Strbig(Llen, t); 
  Strbig(Llen,u);
  short i,j, ls;
  Byte key;
  Bool error, err;
  char dtype;
  Word wval=0;
  double rval= 0.0;
  ls=length(s);
  error=False;
  i=0;
  j= spos("//", s); /* stop before comment if any */
  If j>0 Then ls= j-1 EndIf
   /* bug: doesnt work. need to  revise getexpress ... !!! */
  i=0;
  While (i<ls) And (s[i]<=' ') Do Inc(i) Done
  If s[i]==Intro Then Inc(i) EndIf
  If s[i]=='.' Then  /* skip any dot keyword */
    While s[i]>' ' Do Inc(i) Done
  EndIf
  While (i<ls) And (Not error) Do
    key=getword(s,t, i, Addr(i));
    If (t[0]==0) Or (key>0) Then 
      error=message( dico," Identifier expected")
    EndIf
    If Not error Then /* assignment expressions */
      While (i<=ls) And (s[i-1] !='=') Do Inc(i) Done
      If i>ls Then 
         error= message( dico," = sign expected .") 
      EndIf
      dtype=getexpress(s,u, Addr(i));
      If dtype=='R' Then 
        rval=formula( dico, u, Addr(error));
        If error Then 
          message( dico," Formula() error.") 
        EndIf 
      ElsIf dtype=='S' Then 
        wval= i 
      EndIf
      err=define(dico,t, mode /*was ' ' */ , dtype,rval,wval,Null); 
      error= error Or err;
    EndIf
    If (i<ls) And (s[i-1] != ';') Then 
      error=message( dico," ; sign expected.")
    Else /*Inc(i)*/ 
    EndIf 
  Done
  return error
EndFunc

Func Bool nupa_subcktcall( tdico *dico, Pchar s, Pchar x, Bool err)
/* s= a subckt define line, with formal params.
   x= a matching subckt call line, with actual params 
*/
Begin
  short n,m,i,j,k,g,h, narg=0, ls, nest;
  Strbig(Llen,t);
  Strbig(Llen,u);
  Strbig(Llen,v);
  Strbig(Llen,idlist);
  Str(80,subname);
	  
  /***** first, analyze the subckt definition line */
  n=0; /* number of parameters if any */
  ls=length(s);
  j=spos("//",s);
  If j>0 Then pscopy(t,s,1,j-1) Else scopy(t,s) EndIf 
  stupcase(t); 
  j= spos("SUBCKT", t); 
  If j>0 Then
    j= j +6; /* fetch its name */
    While (j<ls) And (t[j]<=' ') Do Inc(j) Done
    While alfanum(t[j]) Do
      cadd(subname,t[j]); Inc(j) 
    Done 
  Else 
    err=message( dico," Not a subckt line!") 
  EndIf;
  i= spos("PARAMS:",t); 
  If i>0 Then 
    pscopy(t,t, i+7, length(t)); 
    While j=cpos('=',t), j>0 Do /* isolate idents to the left of =-signs */
      k= j-2; 
      While (k>=0) And (t[k]<=' ') Do Dec(k) Done
      h=k;
      While (h>=0) And alfanum(t[h]) Do Dec(h) Done
      If alfa(t[h+1]) And (k>h) Then /* we have some id */
        For m=(h+1); m<=k; Inc(m) Do 
          cadd(idlist,t[m])
        Done 
        sadd(idlist,"=$;");
        Inc(n);
      Else 
        message( dico,"identifier expected.")
      EndIf     
      pscopy(t,t, j+1, length(t));
    Done
  EndIf
  /***** next, analyze the circuit call line */
  If Not err Then
    narg=0;
    j=spos("//",x);
    If j>0 Then pscopy(t,x,1,j-1) Else scopy(t,x) EndIf 
    stupcase(t);
    ls=length(t);
    j= spos(subname,t); 
    If j>0 Then
      j=j + length(subname) -1; /* 1st position of arglist: j */
      While (j<ls) And ((t[j]<=' ') Or (t[j]==',')) Do Inc(j) Done 
      While j<ls Do /* try to fetch valid arguments */
        k= j; 
        scopy(u,"");
        If (t[k]==Intro) Then /* handle historical syntax... */
          If alfa(t[k+1]) Then 
            Inc(k)
          ElsIf t[k+1]=='(' Then /* transform to braces... */
            Inc(k); t[k]='{';
            g=k;  nest=1;
            While (nest>0) And (g<ls) Do
              Inc(g); 
              If t[g]=='(' Then Inc(nest) 
              ElsIf t[g]==')' Then Dec(nest)
              EndIf
            Done
            If (g<ls) And (nest==0) Then t[g]='}' EndIf
          EndIf
        EndIf
        If alfanum(t[k]) Then /* number, identifier */
          h=k; 
          While t[k] > ' ' Do Inc(k) Done
          pscopy(u,t, h+1, k-h); 
          j= k;    
        ElsIf t[k]=='{' Then
          getexpress(t,u, Addr(j)); 
          Dec(j); /* confusion: j was in Turbo Pascal convention */
        Else 
          Inc(j);
          If t[k]>' ' Then 
            scopy(v,"Subckt call, symbol "); 
            cadd(v,t[k]); 
            sadd(v," not understood");
            message( dico,v);
          EndIf 
        EndIf
        If NotZ(u[0]) Then 
          Inc(narg);
          k=cpos('$',idlist); 
          If k>0 Then /* replace dollar with expression string u */
            pscopy(v,idlist,1,k-1);
            sadd(v,u); 
            pscopy(u,idlist, k+1, length(idlist));
            scopy(idlist,v); 
            sadd(idlist,u); 
          EndIf
        EndIf
      Done
    Else 
      message( dico,"Cannot find called subcircuit") 
    EndIf 
  EndIf
  /***** finally, execute the multi-assignment line */
  dicostack(dico, Push);  /* create local symbol scope */
  If narg != n Then
    scopy(t," Mismatch: ");
    nadd(t,n); 
    sadd(t,"  formal but ");
    nadd(t,narg); 
    sadd(t," actual params."); 
    err= message( dico,t);
    message( dico,idlist);
  /* Else debugwarn(dico, idlist) */
  EndIf
  err= nupa_assignment(dico, idlist, 'N');      
  return err
EndFunc

Proc nupa_subcktexit( tdico *dico)
Begin
  dicostack(dico, Pop);
EndProc