' This is the minimum cobol compiler.  It is used to compile the bootstrap 
' COBOL compiler which can then compile further versions.  Target will be 
' Freebasic code, which can be run through this compiler for test.
'
' Version 0.01
'
' By Paul Robinson
'
' 12/28/2006 - 4/19/2007
'
' Copyright 2007 by Viridian Development Corporation, Arlington Virginia
'
' WWW.CODE-COMPILER.COM
'
' Note that this is a one-pass compiler, it does very little forward looking
' This is a "proof of concept" compiler, it was designed to prove a theory;
' and provide an answer the following question:
'
' Is the Basic language adequate (powerful enough) to write either a compiler
' for, or provide a target environment for, the Cobol Programming Language?
'
' Having determined that it is feasable, a full-service compiler will be
' worked upon from scratch as this was done as a "quick and dirty" type
' test to see if it was worth trying.
'
' This program is licensed subject to version 2.0 of the GNU Public License
'
' Note: This program was inteded to be compiled with the Free Basic compier,
' and not with Visual Basic.  It may or may not compile with Visual Basic.
' Due to the fact that it does some constructs not present (such as 
' predeclaring procedures and functions) it probably shouldn't be too
' difficult to compile using VB, but it would need to be translated.  Also,
' the code it generates is also intended to be compiled using Free Basic.

' Reasoning: Free Basic is quite adequate for making simple command-line
' type applications that run in a console window, which is all that is 
' necessary for right now. A compiler run in Visual Basic requires 
' development of a form, and also, it's not portable to any other machine.
' It was felt that the need to just "put something out" as a demonstration
' was more important than spending a considerable amount of time designing
' an application with screen forms and other such overhead

' The compiler is using Free Basic since it's presumed that the target 
' audience for the actual compiler is people wanting to move older mainframe
' or minicomputer Cobol applications to Linux (or windows).  If I can't
' eventually make the compiler self hosting, Basic (or maybe Object Pascal) 
' is probably the best choice for a string-oriented program.
'

OPTION EXPLICIT
Const MaxFiles = 20

DIM SHARED FileID(MaxFiles)        as string     ' Internal ID
DIM SHARED FileBuffer(MaxFiles)    as string     ' var assigned to file's buffer
DIM SHARED FD_COUNT                as Integer    ' Number of files defined
DIM SHARED File_Count              As Integer    ' Number of files defined

DIM SHARED PREFIX_CODE(2000)       as string     ' Code to be inserted ahead of program
DIM SHARED Prefix_Count            as Integer    ' Number of lines of prefix code
DIM SHARED INIT_Code(2000)         as string     ' Code to be inserted into initialization procedure
DIM SHARED INIT_COUNT              as Integer    ' Number of init lines
Dim Shared Codebuffer(10000)       as string     ' Store code buffer until generated
Dim Shared Code_Count              as Integer    ' Number of lines of code buffer used
Dim Shared Variables(4000,2)       as string     ' Convert 05 vars to unions 
DIM Shared Variable_Count          as Integer    ' Variables defined 
Dim Shared Paragraphs(2000)        as string     ' All paragraph names used
Dim Shared Paragraph_Count         as Integer    ' Number of paragraphs defined
Dim Shared Record_Def(2000)        as String     ' Record Definitions 
Dim Shared Record_Count            as Integer    ' Number of record definitions
DIM SHARED CURRENT_PARAGRAPH       as STRING     ' Its name
DIM SHARED CURRENT_LINE            as STRING     ' This Line number
DIM SHARED LINE_REMAINDER          As STRING     ' Text following keyword
DIM SHARED PROGRAM_NAME            AS String     ' Name of this program
DIM SHARED DEBUG_LEVEL             AS INTEGER    ' How much compiler debugging info
dim shared error_count             aS integer    ' Number of errors found
Dim shared Identifier              as String     ' Current identifier found
DIM SHARED LINE_SHOWN              AS INTEGER    ' Did we show this line number
DIM SHARED LINE_COUNT              AS INTEGER    ' Number of source lines read

#DEFINE FALSE  0
#DEFINE TRUE NOT FALSE

' Local to main
DIM  SHARED IN_PROC  as INTEGER             ' Are we in Procedure Division
DIM  SHARED IN_FD    as integer             ' are we inside an FD
DIM  SHARED FD_NAME  AS String              ' LAST NAMED FD
DIM  SHARED IN_01    as INTEGER             ' Are we inside an 01 record def
DIM  SHARED LAST_01  AS String              ' Name of the previous 01 level
DIM  SHARED IN_COND  as Integer             ' Are we in a conditional statement (READ AT END)
DIM  SHARED TEMP$
dim  shared do_pause as integer             ' Pause as needed
DIM L$, C$, K$
DIM KW as Integer
Dim I as Integer

declare SUB Errmsg(MSG$) 
Declare sub Debug(Level as Integer,Msg as String)
DECLARE SUB NoPeriod
DECLARE SUB ID_DIVISION
DECLARE SUB PROGRAM_ID
DECLARE SUB ENVIRONMENT_DIVISION
DECLARE SUB INPUT_OUTPUT
DECLARE SUB FILE_CONTROL
DECLARE SUB SELECT_STATEMENT
DECLARE SUB FILE_SECTION
DECLARE SUB DATA_DIVISION
DECLARE SUB FD_DEF
DECLARE SUB DEFINE_01
DECLARE SUB DEFINE_05
DECLARE SUB WORKING_STORAGE
DECLARE SUB PROCEDURE_DIVISION
DECLARE SUB DEFINE_PARAGRAPH
DECLARE SUB OPEN_STATEMENT
DECLARE SUB IF_STATEMENT
DECLARE SUB PERFORM_STATEMENT
DECLARE SUB CLOSE_STATEMENT
DECLARE SUB STOP_STATEMENT
DECLARE SUB READ_STATEMENT
DECLARE SUB WRITE_STATEMENT
DECLARE SUB MOVE_STATEMENT
DECLARE SUB CONTINUE_STATEMENT
DECLARE SUB COMPUTE_STATEMENT
DECLARE SUB DISPLAY_STATEMENT
DECLARE SUB PUSH_CODE(Code as String)
DECLARE SUB CLEAN_IDENTIFIER(Identifier as string)
DECLARE SUB PUSH_PREFIX(PREFIX$)
DECLARE SUB PUSH_INIT(INIT$)
declare sub PAUSE
declare sub QUOTE_CONVERT(byref Message_Text as String)


' ** MAIN **

    PROGRAM_NAME      = "(NONAME)"
    IN_PROC           = FALSE
    IN_COND           = FALSE
    DEBUG_LEVEL       = 10
    LINE_Count        = 0
    File_Count        = 0
    Code_Count        = 0
    Paragraph_Count   = 0
    Prefix_Count      = 0
    Do_Pause          = 1
    Variable_count    = 0


    chdir "C:\paul\code compiler"
    print 
    print "** PROGRAM BEGINS **"
    
    push_INIT " "
    PUSH_INIT "' ** MAIN **
    PUSH_INIT " "
    
    Open "SOURCE.COB" FOR INPUT AS #1
    Open "DEST.BAS" FOR OUTPUT AS #2
    if EOF(1) THEN
        PRINT "EOF"
        INPUT TEMP$
        stop
    ENDIF
    WHILE NOT EOF(1)
        LINE INPUT #1, L$
        Line_Shown=False
        Line_Count += 1
        CURRENT_LINE = Left(L$,6)
        
        C$ = MID$(L$,7,1)
        IF C$<>" " THEN    ' Comment or meta command
            SELECT CASE C$
               CASE "*"
                 call DEBUG(10, "** COMMENT ")
               CASE "$"
                 LINE_REMAINDER = TRIM(MID$(L$,8,LEN(L$)))
                 IF LEFT(LINE_REMAINDER,5)="DEBUG" THEN
                    DEBUG_LEVEL = VAL(TRIM(MID(LINE_REMAINDER,7,LEN(LINE_REMAINDER))))
                    
                    call debug(5,"**DEBUG ESTIMATE "+str(debug_level))
                 END IF    
            END SELECT     
        ELSE    
            
' While the actual code in some cases will be in margin B, we will ignore prefix blanks        
            TEMP$ = ltrim(Mid$(L$,8,LEN(L$)))+" " ' Line always has at least one blank at end
            CALL DEBUG(10, "TEMP$='"+TEMP$+"'")
' Get the keyword
            K$=" "
            KW = INSTR(TEMP$," ")-1
'            START_POINT = KW
    '            CALL DEBUG(10, "START POINT "+str(START_POINT))
            if KW > 0 then 
                K$ = Mid$(TEMP$,1,KW)
                LINE_REMAINDER = TRIM(MID$(TEMP$,KW+1,LEN(TEMP$)))
            ELSE
                if TRIM(TEMP$)<>"" THEN
                    
                   CALL ERRMSG("KW="+str(KW)+" No SPACE: ")                
                   PRINT K$
                   PRINT "L$='";L$;"'"
                   K$ = "*BAD*"
                END IF
            END IF    
            IF DEBUG_LEVEL > 9 THEN 
                PRINT "*";K$;"*"
                PRINT "REM='";LINE_REMAINDER;"'"
    
            ENDIF    
            IF K$<>"" THEN
             
 ' All paragraph names start with 2 for this exercise; makes this program simpler
 
              if LEFT(k$,1)="2"  THEN 
                 CURRENT_PARAGRAPH = Left(K$,len(K$)-1)
                 Clean_Identifier(Current_Paragraph)
                 if RIGHT(K$,1)<>"." then noperiod
                 K$ = "$DEFPARA"                 
              END IF   
              
              IF K$<>" " THEN
               SELECT CASE K$
            
               CASE "IDENTIFICATION" 
                   CALL ID_DIVISION
                CASE "PROGRAM-ID." 
                   CALL PROGRAM_ID
        
                CASE "ENVIRONMENT" 
                   CALL  ENVIRONMENT_DIVISION
                CASE "INPUT-OUTPUT" 
                   CALL  INPUT_OUTPUT
                CASE "FILE-CONTROL." 
                   CALL  FILE_CONTROL
                CASE "SELECT" 
                   CALL  SELECT_STATEMENT
        
                CASE "DATA" 
                   CALL DATA_DIVISION
                CASE "FILE" 
                   CALL  FILE_SECTION
                CASE "FD" 
                   CALL  FD_DEF
                CASE "01"
                   CALL  DEFINE_01  
                CASE "05"
                   CALL  DEFINE_05  
                CASE "WORKING-STORAGE" 
                   IN_FD = false 
                   CALL  WORKING_STORAGE
    
                CASE "PROCEDURE" 
                   CALL  PROCEDURE_DIVISION
                CASE "$DEFPARA"           ' Internal to compiler for work
                   CALL  DEFINE_PARAGRAPH
                CASE "OPEN" 
                   CALL  OPEN_STATEMENT               
                CASE "IF" 
                   CALL  IF_STATEMENT
                CASE "PERFORM"                    
                   CALL  PERFORM_STATEMENT
                CASE "CLOSE"                    
                   CALL  CLOSE_STATEMENT
                CASE "STOP"
                   CALL  STOP_STATEMENT
                CASE "READ"
                   CALL  READ_STATEMENT
                CASE "WRITE"                    
                   CALL  WRITE_STATEMENT
                CASE "MOVE"
                   CALL  MOVE_STATEMENT
                CASE "COMPUTE"
                   CALL  COMPUTE_STATEMENT
                CASE "CONTINUE."
                   CALL CONTINUE_STATEMENT
                CASE "DISPLAY"   
                   CALL DISPLAY_STATEMENT

                CASE ELSE
                   PRINT "$$ ERROR : "; K$
    
              END SELECT    
             ELSE
               PRINT "** Blank line "  
             ENDIF    
            ENDIF
        ENDIF
        
    WEND
    CLOSE #1
    if paragraph_count > 0 then print #2,"'Paragraph Declarations"
    For I = 1 to Paragraph_Count
        Print #2, "DECLARE SUB ";Paragraphs(I)
        PRINT #2,
    NEXT
    
' Generate all of the information to be put before the program    
    if prefix_count > 0 then 
        
        PRINT #2,"' Prefix Code"
        For I = 1 to Prefix_Count
           Print #2, Prefix_Code(I)
        NEXT
        PRINT #2,"' End of prefix code"
    end if
        
    
    Print #2,"' Initializations"
    
    FOR I = 1 to INIT_Count
        PRINT #2, Init_Code(I)
    NEXT    
    
    
    For I = 1 to Code_Count
        print #2, CodeBuffer(I)
    next    
    
    PRINT #2, "END SUB"
    
    CLOSE #2
    
    print "** PROGRAM COMPLETED **"
    INPUT TEMP$
    
    END


' Misc Support routines

SUB PAUSE
    IF DO_PAUSE THEN
        INPUT TEMP$
        IF TEMP$="/" THEN DO_PAUSE=0
    ENDIF
END SUB    

sub Debug(Level as Integer,Msg as String)
    if debug_level >=level then print msg    
end sub

sub QUOTE_CONVERT(byref Message_Text as String)
    Dim Q as Integer
    Q = instr(Message_text,"""")
    Print "*** QC 0 Q=";Q;"Message_text='";Message_text;"'"
    WHILE Q > 0 
        message_text= LEFT(Message_Text,Q-1)+""""+Mid(Message_Text,Q,len(Message_Text)+1)
        Q = INSTR(Q+2,Message_Text,"""")
    WEND
    
end sub
    

SUB Errmsg (MSG$)
    if not line_shown then
       PRINT "$$ ERROR AT ";
       if trim(current_line)<>"" then
           print "SOURCE LINE ID ";CURRENT_LINE;", ";
       endif    
       PRINT "LINE NUMBER "; Line_Count
       PRINT "$$ ";
       line_shown = true
    else   
       PRINT "$$ ";
    endif   
    print MSG$
    ERROR_COUNT = ERROR_COUNT+1
END SUB
    
Sub EXPECT_ERROR(AFTER$,BEFORE$)
    CALL ERRmsg(AFTER$+" EXPECTED AFTER "+BEFORE$)
END sub

Sub Noperiod
    Call Errmsg ("Period Expected")
END SUB    

SUB EXPECTING (FIRST_KEY$, SECOND_KEY$)
' A particular keyword must be followed by another
    IF LINE_REMAINDER <> SECOND_KEY$ _
      THEN CALL EXPECT_ERROR(SECOND_KEY$,FIRST_KEY$)
END SUB

SUB FOLLOW_DIVISION (FROM_KEY$)
' A particular keyword must be followed by 'Division.'    
    CALL EXPECTING (FROM_KEY$, "DIVISION.")
END SUB

SUB Get_Identifier(byref KW as Integer ,byref Identifier as string)
     KW = INSTR(LINE_REMAINDER," ")-1
     if kw < 1 then kw=len(Line_Remainder)
     identifier=""
     if KW>0 then Identifier = LEFT(LINE_REMAINDER,KW) 
     Clean_Identifier(Identifier)
end sub  

SUB Clean_Identifier(Byref Identifier as String)     
    DIM DASH as Integer
     Dash = Instr(Identifier,"-")
     while Dash>0 
        Identifier=Mid(Identifier,1,Dash-1)+"_"+Mid(Identifier,dash+1,len(identifier))
        Dash = Instr(Identifier,"-")
     wend
     
end sub

Sub Get_Dot_Identifier(byref kw as integer, byref identifier as string)
    Line_Remainder = trim(Mid(Line_Remainder,KW+1,LEN(LINE_REMAINDER)))
    KW=INSTR(Line_Remainder,".")
    if kw<1 then kw=len(Line_Remainder)
    Identifier = Mid(Line_Remainder,1,KW-1)
    Clean_Identifier(Identifier)
    Line_Remainder = Mid(Line_Remainder,kw,len(Line_Remainder))
    IF lINE_REMAINDER <>"." THEN NOPERIOD 
    
END SUB

SUB Get_Condition(Byref Condition as String)
    DIM Source_Identifier as String
    DIM Comparison_Operator as String
    Dim Target_Identifier as String
    DIM KW AS INTEGER
    GET_IDENTIFIER(KW,Source_IDENTIFIER)
    Line_Remainder = trim(Mid(Line_Remainder,KW+1,LEN(LINE_REMAINDER)))
    GET_IDENTIFIER(KW,Comparison_Operator)
    Line_Remainder = trim(Mid(Line_Remainder,KW+1,LEN(LINE_REMAINDER)))
    GET_IDENTIFIER(KW,Target_Identifier)
    If right(Target_Identifier,1)="." then 
        Target_Identifier = Left(Target_Identifier,len(Target_Identifier)-1)
    endif        
    CONDITION = "C_"+SOURCE_IDENTIFIER+" "+COMPARISON_OPERATOR+" C_"+TARGET_IDENTIFIER

END SUB

SUB DEMAND(Desired_Keyword AS STRING)
    DIM KW AS INTEGER
    DIM K as String
    KW = INSTR(LINE_REMAINDER," ")-1
    if kw < 1 then kw=len(Line_Remainder)
    K$ = LEFT(LINE_REMAINDER,KW)
    
    LINE_REMAINDER = TRIM(MID$(LINE_REMAINDER,KW+1,LEN(LINE_REMAINDER)))
    IF K$<>DESIRED_KEYWORD THEN 
        CALL ErrMsg("EXPECTING '"+DESIRED_KEYWORD+"' FOUND '"+K$+"'" )
    ENDIF   
END SUB

SUB PUSH_CODE(CODE$)
    CODE_COUNT += 1
    CODEBUFFER(CODE_COUNT)=CODE$
END SUB

SUB PUSH_INIT(INIT$)
    INIT_COUNT += 1
    INIT_CODE(INIT_COUNT)=INIT$
END SUB

SUB PUSH_PREFIX(PREFIX$)
    PREFIX_COUNT +=1
    PREFIX_CODE(PREFIX_COUNT)=PREFIX$
END SUB    


SUB Add_Variable(Original as String,Conversion as string)
' Given a variable, store the original variable and its mapping
    Variable_Count +=1
    Variables(Variable_Count,1)=Original
    Variables(Variable_Count,2)=Conversion
    PRINT "** addvar orig='";original;"' Conv='";conversion;"'"
    INPUT temp$
end sub


Sub Check_Variable(Original as String, NewVar as String)
    DIM I as Integer
    
' Given a variable, convert it to the mapped variable if any
    FOR I = 1 to Variable_Count
        If Variables(I,1)=Original then 
            PRINT "** chkvar orig='";original;"' Conv='";VARIABLES(i,2);"'"
            newvar = Variables(I,2)
            
            exit sub
        end if
    next
    newvar=original
end sub    

' Keyword Processors
SUB ID_DIVISION
    CALL FOLLOW_DIVISION("IDENTIFICATION")
END SUB

SUB PROGRAM_ID
    LINE_REMAINDER=TRIM(LINE_REMAINDER)
    IF RIGHT(LINE_REMAINDER,1)="." THEN
       PROGRAM_NAME = LEFT(LINE_REMAINDER,len(Line_Remainder)-1)
    ELSE
       NoPeriod
       
    ENDIF    
    
END SUB


SUB ENVIRONMENT_DIVISION
    CALL DEBUG(5, "**IN ENVIRONMENT DIVISION")
    CALL FOLLOW_DIVISION ("ENVIRONMENT")
END SUB
SUB INPUT_OUTPUT
    CALL DEBUG(5, "**IN INPUT_OUTPUT")
    EXPECTING ("INPUT-OUTPUT","SECTION.")
END SUB
SUB FILE_CONTROL
    CALL DEBUG(5, "**IN FILE CONTROL")
END SUB

SUB SELECT_STATEMENT
    DIM KW AS Integer
    Dim Quote as String
' Create a constant for select and use for file I/O    
    CALL DEBUG(5, "**IN SELECT")
' Get the next identifier as a file name
     Get_Identifier(KW,Identifier)
          
     
     LINE_REMAINDER = TRIM(MID$(LINE_REMAINDER,KW+1,LEN(LINE_REMAINDER)))    
     call demand("ASSIGN")
     Call demand("TO")
     
     quote = Left(Line_Remainder,1)
     If quote ="'" OR quote="""" THEN
        LINE_REMAINDER=MID(LINE_REMAINDER,2,len(LINE_REMAINDER))
        KW=INSTR(Line_Remainder,Quote)-1
        IF KW>0 THEN
           Prefix_Count += 1
           Prefix_Code(Prefix_Count)="CONST CN_"+Identifier+" = """+Left(Line_Remainder,KW)+""""
           Line_Remainder = TRIM(Mid(Line_Remainder,KW+1,LEN(LINE_REMAINDER)))
           if Line_Remainder <> Quote+"." THEN NOPERIOD
           
           
        ELSE
           CALL Errmsg("String not terminated by "+quote)
        ENDIF 
     ELSE
        CALL ERRMSG ("Quote expected")
     ENDIF
     file_count +=1
     FileID(File_Count)=Identifier
     
     PUSH_Prefix "CONST C_"+FileID(File_Count)+" = "+Str(File_Count) 
     
END SUB


SUB DATA_DIVISION
    CALL DEBUG(5, "**IN DATA DIVISION")
    CALL FOLLOW_DIVISION ("DATA")
END SUB
SUB FILE_SECTION  
    CALL DEBUG(5,  "**IN FILE SECTION")
    CALL DEMAND("SECTION.")
END SUB

SUB FD_DEF
    DIM as Integer i, KW
    DIM FOUND As iNTEGER
    
    CALL DEBUG(5,  "**IN FD ")
    KW = INSTR(LINE_REMAINDER,".")-1
    if kw > 1 then 
        FD_NAME = Trim(left(line_remainder,kw))
        
        Clean_Identifier(FD_NAME)
        in_fd = 0
        fOR i = 1 TO FILE_COUNT
           IF fileid(i) = fd_name THEN
              IN_fD = I
              exit for
           end if   
        NEXT
        if IN_fd < 1 then      ERRMSG("FD for "+FD_name+" Not SELECTED ")
        
    else
        call noperiod
    endif    
END SUB

SUB CHECK_IN01
' This checks to see if there was an 01 level previously defined and still
' open; if so, close its definition and generate the definition.

    IF IN_01 THEN
        PUSH_PREFIX "  END TYPE"
        PUSH_PREFIX "DIM C_"+LAST_01+" AS T_"+LAST_01
        LAST_01=""

        IN_01 = FALSE
    END IF
    
END SUB

SUB CHECK_IN_COND
    ' Check if we were in a conditional in order to close it
    IF IN_COND THEN
        PUSH_CODE "    END IF "
        IN_COND = FALSE
    END IF    
    
END SUB

SUB DEFINE_01
    Dim as Integer KW, K2 
    DIM as String Var ,  Modifier , Constant_Value , Value_Spec 
    
    CALL DEBUG(5,  "**IN DEF 01")
' An 01 with a Picture is a variable; an 01 with no picture is a record    

' See if we are currently in an unclosed 01; if so, close it
    CHECK_IN01

    
    GET_IDENTIFIER(KW,VAR)
    print "** DEF01 A KW=";kw;" VAR=/";VAR;"/ k2=";k2;" CV=/";constant_value;"/ iD=/";identifier;"/  LR=/";Line_Remainder;"/"    
    IF right(VAR,1)<>"." THEN ' This is a variable
        LINE_REMAINDER = TRIM(MID$(LINE_REMAINDER,KW+1,LEN(LINE_REMAINDER)))    
        GET_IDENTIFIER(KW,identifier)   ' Get PIC or PICTURE
        print "** DEF01 B KW=";kw;" VAR=/";VAR;"/ k2=";k2;" CV=/";constant_value;"/ iD=/";identifier;"/  LR=/";Line_Remainder;"/"    
        LINE_REMAINDER = TRIM(MID$(LINE_REMAINDER,KW+1,LEN(LINE_REMAINDER)))    
        Identifier = TRIM(MID$(LINE_REMAINDER,KW+1,K2-Kw))   
        print "** DEF01 C KW=";kw;" VAR=/";VAR;"/ k2=";k2;" CV=/";constant_value;"/ iD=/";identifier;"/  LR=/";Line_Remainder;"/"    
        kw=instr(line_remainder,"(")
        if kw > 0 then
            k2=instr(line_remainder,")")
            K2 = K2 - KW - 1
    
            MODIFIER = " *"+ MID$(LINE_REMAINDER,KW+1,K2)+ " "
        else 
            modifier = " *1 "
        endif
        print "** DEF01 01 KW=";kw;" k2=";k2;" modifier=/";modifier;"/"
        LINE_REMAINDER = TRIM(MID$(LINE_REMAINDER,KW+1,LEN(LINE_REMAINDER)))    
        kw = instr(line_remainder,"VALUE")
        if kw>0 then
            Line_Remainder = TRIM(MID$(LINE_REMAINDER,KW+6,LEN(LINE_REMAINDER)))    
            print "** DEF01 03 KW=";kw;"  LR=/";Line_Remainder;"/"
            constant_value=TRIM(MID$(LINE_REMAINDER,2,LEN(LINE_REMAINDER)-3))    ' Drop leading & trailing Quote
            Quote_Convert Constant_Value         ' Translate any " to ""
      
            push_INIT "    C_"+ var+" = """+CONSTANT_Value + """  ' VALUE CLAUSE "
            MODIFIER = MODIFIER + " ' ASSIGNED VALUE: "+CONSTANT_Value 
        endif    
        ADD_VARIABLE VAR,VAR
        push_Prefix "DIM SHARED C_"+VAR+" AS STRING "+MODIFIER 
    ELSE    ' This is an 01 record-level variable
        VAR=MID(VAR,1,len(VAR)-1)   ' Chop off the period
        IN_01 = TRUE
        LAST_01=VAR
        PUSH_PREFIX "TYPE T_"+VAR
    ENDIF    
    print "** DEF01 15 KW=";kw;" VAR=/";VAR;"/ k2=";k2;" CV=/";constant_value;"/ iD=/";identifier;"/  LR=/";Line_Remainder;"/"
    pause
    
    
    
    if in_FD >0 then
' Assign this as the buffer for this file
        print "**def01 20 in_fd=";in_fd;" nM="; fd_name
        FILEBUFFER(IN_fd) = var    
        IN_FD=0
    endif
END SUB    

SUB DEFINE_05
' An 05 is a field in a record
    
    CALL DEBUG(5,  "**IN DEF 05")
    Dim as Integer KW, K2 
    DIM as String Var ,  Modifier , Constant_Value , Value_Spec , New_Var
    
    if NOT IN_01 THEN ERRMSG("05 must follow an 01 definition")
    GET_IDENTIFIER(KW,VAR)
    LINE_REMAINDER = TRIM(MID$(LINE_REMAINDER,KW+1,LEN(LINE_REMAINDER)))    
    GET_IDENTIFIER(KW,identifier)   ' Get PIC or PICTURE
    print "** DEF05 B KW=";kw;" VAR=/";VAR;"/ k2=";k2;" CV=/";constant_value;"/ iD=/";identifier;"/  LR=/";Line_Remainder;"/"    
    LINE_REMAINDER = TRIM(MID$(LINE_REMAINDER,KW+1,LEN(LINE_REMAINDER)))    
    Identifier = TRIM(MID$(LINE_REMAINDER,KW+1,K2-Kw))   
    print "** DEF05 C KW=";kw;" VAR=/";VAR;"/ k2=";k2;" CV=/";constant_value;"/ iD=/";identifier;"/  LR=/";Line_Remainder;"/"    
    kw=instr(line_remainder,"(")
    New_Var = LAST_01+".C_"+VAR
    
    if kw > 0 then
            k2=instr(line_remainder,")")
            K2 = K2 - KW - 1
    
            MODIFIER = " *"+ MID$(LINE_REMAINDER,KW+1,K2)+ " "
    else 
            modifier = " *1 "
    endif
    print "** DEF05 01 KW=";kw;" k2=";k2;" modifier=/";modifier;"/"
    LINE_REMAINDER = TRIM(MID$(LINE_REMAINDER,KW+1,LEN(LINE_REMAINDER)))    
    kw = instr(line_remainder,"VALUE")
    if kw>0 then
          Line_Remainder = TRIM(MID$(LINE_REMAINDER,KW+6,LEN(LINE_REMAINDER)))    
          print "** DEF05 03 KW=";kw;"  NEW_VAR='";NEW_VAR;"'  LR=/";Line_Remainder;"/"
          constant_value=TRIM(MID$(LINE_REMAINDER,2,LEN(LINE_REMAINDER)-3))    ' Drop leading & trailing Quote
          Quote_Convert Constant_Value         ' Translate any " to ""
      
          push_INIT "    "+NEW_VAR+" = """+CONSTANT_Value + """  ' VALUE CLAUSE "
          MODIFIER = MODIFIER + " ' ASSIGNED VALUE: "+CONSTANT_Value 
     endif    
     ADD_VARIABLE VAR,NEW_VAR
     push_Prefix "        "+VAR+" AS STRING "+MODIFIER 
     PRINT "** 05 E VAR='";VAR;"' NEWVAR='";NEW_VAR;"'"
    
END SUB    
sub WORKING_STORAGE
    In_FD = FALSE
    CALL DEBUG(5,  "**IN WS")
    CALL DEMAND("SECTION.")
END SUB




sub PROCEDURE_DIVISION
    CALL DEBUG(5, "**IN PROCEDURE DIVISION")
' See if we are currently in an unclosed 01; if so, close it
    CHECK_IN01
    
    CALL FOLLOW_DIVISION ("PROCEDURE")
    IN_PROC = TRUE
    
END SUB

SUB DEFINE_PARAGRAPH
    CALL DEBUG(5,  "** DEF PARA")
    Paragraph_Count += 1
    Paragraphs(Paragraph_Count)="C_"+Current_Paragraph
    
    if paragraph_count = 1 then
' First time, insert code to call this paragraph and exit
       PUSH_CODE ""
       PUSH_CODE "' Start First Paragraph "
       PUSH_CODE "    CALL C_"+Current_Paragraph
       PUSH_CODE "    PRINT ""** COBOL - AUTOMATIC EXIT **"""
       PUSH_CODE "    INPUT AA"
       PUSH_CODE "    STOP"
    ELSE
'      PUSH_CODE "    PRINT ""End Sub"""
       PUSH_CODE "END SUB"  ' Close previous sub
    endif
    PUSH_CODE "SUB C_"+Current_Paragraph  
'    PUSH_CODE "    PRINT ""--DEBUG ENTER "+Current_Paragraph+" -- """
END SUB

SUB OPEN_STATEMENT
    DIM KW as Integer
    DIM OpenType as String
    CALL DEBUG(5, "** OPEN")
    Get_Identifier(KW,OpenType)
    print "** OP KW=";KW;" OT=";OpenType
    
    If OpenType ="INPUT" or OpenType = "OUTPUT" THEN
        get_dot_identifier (kw,identifier)
        
        print "** OP ID=";identifier;" OT=";OpenType
        PUSH_CODE "    OPEN CN_" + Identifier + " FOR "+OpenType +" AS #C_"+Identifier
        Print "**OP ";Identifier ; " FOR "+OpenType +" AS #"+Identifier
    else
       errmsg("Expecting 'INPUT' or 'OUTPUT', found "+Identifier)
    endif
    pause
    
END SUB
SUB IF_STATEMENT
    DIM COND_NOT AS string
    DIM CONDITION as String
    DIM NEW_VAR as String
    ' IF [NOT] AT END file
    ' IF COND 
    
    DIM KW as Integer
    CALL DEBUG(5, "** IF")
    Get_Identifier(Kw, Identifier)
    

    IF IDENTIFIER = "NOT" THEN 
        COND_NOT = " not  "
        Line_Remainder=Trim(Mid(Line_Remainder,kw+1,len(Line_Remainder)))
    ENDIF    
    if LEFT(line_Remainder,6) = "AT END" THEN
            Line_Remainder=Trim(Mid(Line_Remainder,7,len(Line_Remainder)))
            GET_IDENTIFIER KW,IDentifier
            Check_Variable identifier,new_var
            
            push_code "    if "+COND_NOT+"eof(c_"+new_var+") then"
            
        ELSE    
            GET_CONDITION(Condition)
            push_code "    if "+COND_NOT+Condition+" THEN"
    endif    
    IN_COND = TRUE

END SUB

SUB PERFORM_STATEMENT
    do_pause = 1
    DIM CONDITION AS STRING
    DIM Paragraph_Name as String
    DIM KW AS Integer
    Dim Prefix as String
    if in_cond then prefix = "    "
    CALL DEBUG(5, "** PERFORM")
    print "** IN_COND=";IN_COND
    
    pause
' Two types of perform: 
'          perform paragraph.
'          perform paragraph until condition.
    Get_Identifier Kw,Identifier
       PRINT "** PERF ID=";Identifier
    If right(identifier,1)="." then 
    ' Straight perform
       Identifier=Left(identifier,len(identifier)-1)
       PUSH_CODE prefix+"    CALL C_"+Identifier
    else
    ' Perform UNTIL
       print 
       
       GET_IDENTIFIER kw,Paragraph_Name
       
       Line_Remainder=Trim(Mid(Line_Remainder,kw+1,len(Line_Remainder)))
       Get_Identifier kw,Identifier
       
       If identifier <>"UNTIL" then Errmsg("UNTIL expected")
       Line_Remainder=Trim(Mid(Line_Remainder,kw+1,len(Line_Remainder)))
       
       pausE
       GET_CONDITION CONDITION
       
       PUSH_CODE prefix+"    DO "
       PUSH_CODE prefix+"       CALL C_"+Paragraph_Name
       PUSH_CODE prefix+"    LOOP UNTIL "+CONDITION
       
    end if
    CHECK_IN_COND
END SUB

SUB CLOSE_STATEMENT
    DIM KW AS Integer
    CALL DEBUG(5, "** CLOSE")
    Get_Dot_Identifier kw,Identifier
    PUSH_CODE "   CLOSE #C_"+Identifier 
END SUB

SUB STOP_STATEMENT
' We're not even going to check; all STOP is presumed 'Stop Run'    
    CALL DEBUG(5, "** STOP")
    PUSH_CODE "  PRINT ""** STOP RUN **"""
    PUSH_CODE "  INPUT AA
    PUSH_CODE "  END "    
END SUB

SUB READ_STATEMENT
    DIM FID AS STRING
    DIM PREFIX AS STRING
    DIM AS INTEGER i,k,kw
    
' READ FILE AT END CONDITION.    
    CALL DEBUG(5, "** READ")
    GET_IDENTIFIER KW,FID
    Line_Remainder=trim(MID(Line_Remainder,KW+1,Len(Line_Remainder)))
    if line_Remainder = "AT END" THEN
       IN_COND=TRUE
       PUSH_CODE "    IF NOT EOF(C_"+FID+") THEN"
       PREFIX = "    "
    ENDIF
    
    fOR i = 1 TO FILE_COUNT
       IF fileid(i) = fID THEN
          K = I
          exit for
       end if   
    NEXT
    if K < 1 then      ERRMSG(FID+" NOT SELECTED / FD ")
        
    PUSH_CODE PREFIX+"    LINE INPUT #C_" + FID + ", C_"+FILEBUFFER(K)
    IF IN_COND THEN PUSH_CODE "    ELSE"
    
END SUB
SUB WRITE_STATEMENT
    DIM AS STRING FID 
    DIM AS INTEGER  KW ,K,I
    
' Write record-name.    
    CALL DEBUG(5, "** WRITE" )
    GET_DOT_IDENTIFIER(KW,FID)
    Line_Remainder=trim(MID(Line_Remainder,KW+1,Len(Line_Remainder)))
    
    FOR i = 1 TO FILE_COUNT
       IF filebuffer(i) = fID THEN
          K = I
          exit for
       end if   
    NEXT
    if K < 1 then      ERRMSG(FID+" NOT SELECTED / FD ")
    
    
    PUSH_CODE "    PRINT #C_"+FIleid(K)+", C_"+FileBuffer(k)
    
END SUB

SUB MOVE_STATEMENT
    DIM FIELD1 AS STRING
    DIM FIELD2 AS STRING
    DIM FIELD3 AS STRING
    DIM DUMMY  AS STRING
    DIM TARGET AS STRING
    DIM KW AS INTEGER  
    ' MOVE FIELD1 [FIELD2 [FIELD3]] TO TARGET
    CALL DEBUG(5, "** MOVE" )
    FIELD2=""
    FIELD3=""
    GET_IDENTIFIER KW,FIELD1
    DUMMY = FIELD1
    PRINT "** MOVE A D='";DUMMY;"'"
    Check_Variable dummy, FIELD1
    PRINT "** MOVE B D='";DUMMY;"' F1=";Field1;"'"
    Line_Remainder=trim(MID(Line_Remainder,KW+1,Len(Line_Remainder)))
    
    GET_IDENTIFIER KW,FIELD2
    
    Line_Remainder=trim(MID(Line_Remainder,KW+1,Len(Line_Remainder)))
    
    IF FIELD2="TO" THEN
       FIELD2=""
    ELSE
    
       DUMMY = FIELD2
       PRINT "** MOVE C D='";DUMMY;"'"
       Check_Variable dummy, FIELD2
       PRINT "** MOVE D D='";DUMMY;"' F2=";Field2;"'"
       FIELD2=" + C_"+FIELD2 
       GET_IDENTIFIER KW,FIELD3
       Line_Remainder=trim(MID(Line_Remainder,KW+1,Len(Line_Remainder)))
       IF FIELD3 = "TO" THEN
           FIELD3 = ""
       ELSE    
          DUMMY = FIELD3
          PRINT "** MOVE C D='";DUMMY;"'"
          Check_Variable dummy, FIELD3
          PRINT "** MOVE D D='";DUMMY;"' F2=";Field3;"'"
          FIELD3="+C_"+FIELD3
          GET_IDENTIFIER KW,DUMMY     ' Strip 'TO'
          Line_Remainder=trim(MID(Line_Remainder,KW+1,Len(Line_Remainder)))
       ENDIF    
    ENDIF 
    PRINT "** MOVE 05 LR =";lINE_REMAINDER
    GET_IDENTIFIER KW,TARGET
    PRINT "** move 20 kw =";KW;" TARGET ='";tARGET;"'"
    
    if right(Target,1)<>"." then noperiod
    target = left(Target,len(Target)-1)
    DUMMY = TARGET
    PRINT "** MOVE 25 D='";DUMMY;"'"
    Check_Variable dummy, TARGET
    PRINT "** MOVE 30 D='";DUMMY;"' TARGET='";TARGET;"'"

    
    PUSH_CODE "    C_"+TARGET+" = C_"+ FIELD1 +FIELD2+FIELD3
    Pause
    
END SUB
SUB CONTINUE_STATEMENT
    CALL DEBUG(5, "** CONTINUE" )
    PUSH_CODE "  REM -- CONTINUE "
END SUB
SUB COMPUTE_STATEMENT
    CALL DEBUG(5, "** COMPUTE" )
END SUB
sub DISPLAY_STATEMENT
    DIM kw as integer
    CALL DEBUG(5, "** DISPLAY" )
    Line_Remainder = LEFT(Line_Remainder,len(Line_Remainder)-1) ' Drop period
    GET_Identifier kw,Identifier
    
    PUSH_CODE "    PRINT C_"+IDentifier
END SUB