* * $Id: siinps.F,v 1.2 1997/03/14 11:57:31 mclareni Exp $ * * $Log: siinps.F,v $ * Revision 1.2 1997/03/14 11:57:31 mclareni * WNT mods * * Revision 1.1.1.1.2.1 1997/01/21 11:35:43 mclareni * All mods for Winnt 96a on winnt branch * * Revision 1.1.1.1 1995/12/12 14:36:18 mclareni * Imported sources * * #include "sigma/pilot.h" *CMZ : 1.10/01 26/10/93 15.09.53 by Carlo E. Vandoni *-- Author : SUBROUTINE SIINPS(JACEK) C C MAIN DRIVER OF STANDARISATION PHASE (SICPH1) C KEEPS IC AS POINTER OF NEXT EXAMINED CHARACTER C OF INPUT STRING FROM ARRAY INSTR. C IF THERE IS NO ERRORS IN CONVERTED STRING INDICATOR C IND IS .TRUE. AFTER RETURN. C IF IND IS .FALSE THE POINER IC POINTS TO WRONG C CHARACTER IN INPUT STRING INSTR. C INSTR MUST BE RIGHT JUSTIFIED - ZERO FILED, AND C MUST CONTAIN CHARACTER VALUES IN DISPLAY CODE, C ONE CHARACTER PER WORD. END OF COMMAND $ SIGN. C STANDARISATION. C 1 , - LABEL C 2 , - REAL NUMBER C 3 , - NAME LEFT JUSTIFIED C 4 , - ALL SEPARATORS C 5 - END OF LINE C 6 , - COMPLEX NUMBER C STRING HAS A CONSTRUCTION. C 4,52,NO-OF-STRING-CHARS,STRING C STANDARDISED OUTPUT CONTAINED IN ARRAY IOUTS. C POINTER 10C,ALLWAYS POINTS TO NEXT FREE WORD IN IT. C ERRORS ENCOUTERED AND SIGNALLED. C C WRONG NAME LENGTH,NUMBER OR CHARACTER C C-------------------------------------------------- C #include "sigma/sicsig.inc" #include "sigma/sigkq.inc" #include "sigma/sigc.inc" #include "sigma/pawc.inc" #include "sigma/sicph1.inc" #include "sigma/sicph2.inc" #include "sigma/sigcmp.inc" #include "sigma/sicst4.inc" #include "sigma/sicfor.inc" #include "sigma/sicsav.inc" SAVE CN SAVE ICSAVA LOGICAL SICOMP,IND,SIWHAT CHARACTER CN*1,SINSTR*1 C EQUIVALENCE( K, X ) CALL SITRAX(' SIINPS ') JAC=JACEK I=1 C 2 CONTINUE IF(LINE.GE.10)GOTO 33 3 CONTINUE IF(SITRAK(40).EQ.1)PRINT *,'LINE= ',LINE C 456 CONTINUE CALL SIRNWS C IC=1 GO TO (8,9,10)JAC 8 IOC=IOC-1 ICSAVA=IOC GO TO 11 9 IOC=1 ICSAVA=IOC GO TO 11 10 IOC=ICSAVA 11 CONTINUE IF(SITRAK(40).EQ.1)PRINT *,'LINE= ',LINE C ISGN=SINSTR(IC) C C REMOVE INITIAL SPACES 100 CONTINUE IF(SICOMP(KQBLAN)) GO TO 100 C C NOW FIND IF COMMENT CARD. IF(SICOMP(KQDOLL)) GO TO 28 C FIND IF STATEMENT BEGINS WITH LABEL. IF(SIWHAT(0)) GO TO 15 C C REMOVE SPACES BETWEEN LABEL AND STATEMENT. 13 CONTINUE 200 CONTINUE IF(SICOMP(KQBLAN)) GO TO 200 C NOTE THAT COLON MAY ALSO BE USED. IF(SICOMP(KQCOLO)) GO TO 200 C C FIND IF SYMBOLIC NAME AND DO IT. IF(SIWHAT(1)) GO TO 16 C C FIND IF NUMBER AND DO IT. IF(SIWHAT(0)) GO TO 20 C C FIND IF FULLSTOP AND DO IT. IF (ISGN .EQ. KQDOT) GO TO 17 C C FIND IF DELIMITER AND DO IT. CALL SIDELI (CN) IF(IND) GO TO 21 C C FIND IF END OF STATEMENT AND DO IT. IF(SICOMP(KQDOLL)) GO TO 25 C C IF N ONE OF ABOVE - ERROR OF PHASE 1. C 14 CONTINUE CALL SIERSY(2) IQUEST(1)=-2 JAC=2 GO TO 3 C C 15 CONTINUE C NUMBER AT THE BEGINNING OF A LINE IS EITHER C A LABEL OR AN INCOMPLETE DISPLAY STATEMENT C OUTPUT I=1 FOR LABEL AND I=2 FOR NUMBER C HAVE NUMBER IFF FOLLOWED BY +-*/&:(. IF PRESENT IS EATEN BY NUMBER) C CALL SINUMB IF (.NOT.(IND)) GO TO 14 151 CONTINUE IF(SICOMP(KQBLAN)) GO TO 151 C I=1 IF(ISGN.EQ.KQPLUS.OR.ISGN.EQ.KQMIN.OR.ISGN.EQ.KQSTAR.OR. ,ISGN.EQ.KQSLAS.OR.ISGN.EQ.KQAMPE.OR.ISGN.EQ.KQPERC) I=2 IF(MODE.EQ.1)GOTO 42 CALL SIOUT(6) ICMM=ICMPI-2 CALL SIOUT(ICMM) GOTO 13 42 CONTINUE C CALL SIOUT (I) CALL SIOUT (XNUM) GO TO 13 C C C CALL TRANSLATE NAME/SYMBOL AND FIND IF NO ERRORS. 16 CALL SISYMB IF(IND) GO TO 13 GO TO 14 C C SPECIAL TREATEMENT OF FULLSTOP, IF IT NOT BELONGS TO THE NUMBER. 17 IC=IC+1 ISGN=SINSTR(IC) K=IC 301 CONTINUE IF(SICOMP(KQBLAN)) GO TO 301 IF(SIWHAT(0)) GO TO 19 GOTO 14 19 IC=K-1 C C NUMBER TRANSLATION CALL AND FIND IF ERROR FREE. 20 CALL SINUMB IF (.NOT. (IND)) GO TO 14 IF(MODE.EQ.1) GOTO 37 CALL SIOUT(6) ICMM=ICMPI-2 CALL SIOUT(ICMM) GOTO 13 37 CONTINUE CALL SIOUT (2) CALL SIOUT (XNUM) GOTO 13 C C CHECK IF STRING OR SYMBOLSTRING FOR DISPLAY C 21 CONTINUE IF (CN .EQ. KQQUOT) GOTO 210 GOTO 13 C 210 CONTINUE 1239 CONTINUE ISGN=SINSTR(IC) IF (SICOMP(KQQUOT)) GO TO 1333 IS22=IOC CALL SIOUT (0) CALL UCTOH(ISGN,ISI2,1,1) CALL SIOUT (ISI2) LL=1 22 CONTINUE IF (.NOT.SICOMP(KQQUOT)) GO TO 23 * * END OF STRING * IS1=IOC IOC=IS22 CALL SIOUT (LL) IOC=IS1 GO TO 13 C 1333 CONTINUE PRINT *,'Null String' CALL SIOUT (1) C CALL SIOUT (ISGN) // V.Fine 27.06.96 CALL UCTOH(ISGN,ISI2,1,1) CALL SIOUT (ISI2) CALL SIOUT (1) goto 13 23 CONTINUE IF (IC .GT. LENSTR) GOTO 14 C ERROR IF CLOSING QUOTE MARK MISSING IC=IC+1 ISGN=SINSTR(IC) CALL UCTOH(ISGN,ISI2,1,1) CALL SIOUT (ISI2) LL=LL+1 GO TO 22 C AND HERE IS END OF REAL SIINPS WORK. 25 CALL SIOUT (5) IND=.TRUE. C UNSAVE POINTERS OF COMPILEC IPOINT=NIPOIN IST=NIST ICSP=NICSP LDISP=NLDISP LNS=NLNS LSTAPO=NLSTAP KS=NKS IC=NIC C C IF (SITRAK(5).EQ.0) GO TO 27 DO 26 I=1,IOC K=IOUTS(I) WRITE (NPRINT,38) K,K,X 38 FORMAT (1X,'IOUTS()=',8X,I6,I6,8X,F16.8) 26 CONTINUE 27 RETURN C C 28 CONTINUE 33 CONTINUE LINE = 9 IN=1 DO 34 I=IN,10 K=I+1 KOLTEX(I)=KOLTEX(K) 34 CONTINUE KOLTEX(10)=' ' GO TO 2 C END