RCSNUSP/COBOL: Difference between revisions

Content added Content deleted
m (Improved code formatting.)
(Modularised code.)
Line 6: Line 6:


{{works with|GNU Cobol|2.0}}
{{works with|GNU Cobol|2.0}}

snusp.cob:
<lang cobol> >>SOURCE FREE
<lang cobol> >>SOURCE FREE
IDENTIFICATION DIVISION.
IDENTIFICATION DIVISION.
PROGRAM-ID. snusp-interpreter.
PROGRAM-ID. snusp-interpreter.


ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
CONFIGURATION SECTION.
FILE-CONTROL.
REPOSITORY.
SELECT code-file ASSIGN code-file-path
FUNCTION find-initial
ORGANIZATION LINE SEQUENTIAL
FUNCTION ALL INTRINSIC
FILE STATUS code-file-status.
.

DATA DIVISION.
DATA DIVISION.
FILE SECTION.
FD code-file.
01 code-record PIC X(100).

WORKING-STORAGE SECTION.
WORKING-STORAGE SECTION.
COPY "dd-program-arguments.cpy".
01 num-args PIC 9 COMP.
01 arg-num PIC 9 COMP.
COPY "dd-code-area.cpy".
01 arg PIC X(100).

01 Flag-Indicator CONSTANT "-".
01 Help-Flag-Char CONSTANT "h".
01 Read-Num-Flag-Char CONSTANT "r".
01 Write-Num-Flag-Char CONSTANT "w".
01 program-flag PIC X.
88 help-flag VALUE Help-Flag-Char.
88 read-num-flag VALUE Read-Num-Flag-Char.
88 write-num-flag VALUE Write-Num-Flag-Char.
01 read-flag PIC X.
88 read-numbers VALUE "N".
01 write-flag PIC X.
88 write-numbers VALUE "N".
01 code-file-path PIC X(100).
01 code-file-status PIC 99.
88 end-of-code-file VALUE 10.

01 num-lines PIC 9(4) COMP.
01 code-area.
03 code-lines OCCURS 1 TO 1024 TIMES
DEPENDING ON num-lines
INDEXED BY line-idx.
05 code-chars PIC X OCCURS 100 TIMES.

01 program-state-flag PIC X VALUE SPACE.
01 program-state-flag PIC X VALUE SPACE.
88 program-ok VALUE SPACE.
88 program-ok VALUE SPACE.
88 empty-stack VALUE "E".
88 empty-stack VALUE "E".
88 out-of-code-space VALUE "O".
88 out-of-code-space VALUE "O".

01 memory-area.
01 memory-area.
03 memory-rows OCCURS 1024 TIMES.
03 memory-rows OCCURS 1024 TIMES.
Line 62: Line 34:
07 memory-cell USAGE BINARY-CHAR.
07 memory-cell USAGE BINARY-CHAR.
07 memory-cell-char REDEFINES memory-cell PIC X.
07 memory-cell-char REDEFINES memory-cell PIC X.

01 num-threads PIC 99 COMP VALUE 1.
01 num-threads PIC 99 COMP VALUE 1.
01 threads-data-area.
01 threads-data-area.
Line 78: Line 50:
88 left-dir VALUE "L".
88 left-dir VALUE "L".
88 right-dir VALUE "R".
88 right-dir VALUE "R".
09 ip-line USAGE INDEX.
09 instruction-ptr.
09 ip-char USAGE INDEX.
11 ip-line USAGE INDEX.
11 ip-char USAGE INDEX.
05 memory-pointer.
05 memory-pointer.
07 row-idx USAGE INDEX.
07 row-idx USAGE INDEX.
Line 85: Line 58:
01 input-char PIC X.
01 input-char PIC X.

01 current-thread-idx USAGE INDEX.
01 current-thread-idx USAGE INDEX.

01 Tab-Char CONSTANT X"09".

PROCEDURE DIVISION.
PROCEDURE DIVISION.
DECLARATIVES.
code-file-error SECTION.
USE AFTER ERROR ON code-file.
DISPLAY "An error occurred while using " FUNCTION TRIM(code-file-path)
DISPLAY "Error code " code-file-status
DISPLAY "The program will terminate."

GOBACK
.
END DECLARATIVES.

000-main SECTION.
000-main SECTION.
001-parse-arguments.
001-prepare-code.
CALL "parse-arguments" USING program-arguments
ACCEPT num-args FROM ARGUMENT-NUMBER
IF num-args = 0
PERFORM 300-display-help
GOBACK
END-IF

PERFORM VARYING arg-num FROM 1 BY 1 UNTIL arg-num > num-args
DISPLAY arg-num UPON ARGUMENT-NUMBER
ACCEPT arg FROM ARGUMENT-VALUE
EVALUATE TRUE
WHEN arg (1:1) = Flag-Indicator
MOVE arg (2:1) TO program-flag
EVALUATE TRUE
WHEN help-flag
PERFORM 300-display-help
GOBACK
WHEN read-num-flag
SET read-numbers TO TRUE
WHEN write-num-flag
SET write-numbers TO TRUE
WHEN OTHER
DISPLAY "Flag '" FUNCTION TRIM(arg) "' not recongnized."
END-EVALUATE
WHEN code-file-path <> SPACES
DISPLAY "Argument " arg-num " ignored - only one source code "
"file can be interpreted."
WHEN OTHER
MOVE arg TO code-file-path
END-EVALUATE
END-PERFORM

IF code-file-path = SPACES
IF code-file-path = SPACES
DISPLAY "No file path specified."
DISPLAY "No file path specified."
GOBACK
STOP RUN
END-IF
END-IF
.
CALL "read-code-file" USING CONTENT code-file-path, REFERENCE code-area
010-read-code-file.
*> Store contents of file into memory.
OPEN INPUT code-file
PERFORM VARYING line-idx FROM 1 BY 1 UNTIL end-of-code-file
ADD 1 TO num-lines
READ code-file INTO code-lines (line-idx)
AT END
SUBTRACT 1 FROM num-lines
EXIT PERFORM
END-READ
END-PERFORM


MOVE find-initial(code-area) TO instruction-ptr (1, 1)
CLOSE code-file
.
.
010-interpret-code.
020-search-for-initial.
PERFORM VARYING ip-line (1, 1) FROM 1 BY 1 UNTIL ip-line (1, 1) > num-lines
AFTER ip-char (1, 1) FROM 1 BY 1 UNTIL ip-char (1, 1) > 100
IF code-chars (ip-line (1, 1), ip-char (1, 1)) = "$"
EXIT PERFORM
END-IF
END-PERFORM
*> Set position to first char if no initial characters were found.
IF ip-line (1, 1) > num-lines
SET ip-line (1, 1), ip-char (1, 1) TO 1
END-IF
.
030-interpret-code.
SET right-dir (1, 1) TO TRUE
SET right-dir (1, 1) TO TRUE
SET stack-idx, thread-idx, row-idx (1), col-idx (1) TO 1
SET stack-idx, thread-idx, row-idx (1), col-idx (1) TO 1
Line 179: Line 83:
PERFORM 200-stop-thread
PERFORM 200-stop-thread
END-IF
END-IF
EVALUATE code-chars (ip-line (thread-idx, stack-idx),
EVALUATE code-chars (ip-line (thread-idx, stack-idx),
ip-char (thread-idx, stack-idx))
ip-char (thread-idx, stack-idx))
Line 185: Line 89:
WHEN "<" *> LEFT
WHEN "<" *> LEFT
SET col-idx (thread-idx) DOWN BY 1
SET col-idx (thread-idx) DOWN BY 1

WHEN ">" *> RIGHT
WHEN ">" *> RIGHT
SET col-idx (thread-idx) UP BY 1
SET col-idx (thread-idx) UP BY 1

WHEN "+" *> INCR
WHEN "+" *> INCR
ADD 1 TO
ADD 1 TO
memory-cell (row-idx (thread-idx), col-idx (thread-idx))
memory-cell (row-idx (thread-idx), col-idx (thread-idx))

WHEN "-" *> DECR
WHEN "-" *> DECR
SUBTRACT 1 FROM
SUBTRACT 1 FROM
memory-cell (row-idx (thread-idx), col-idx (thread-idx))
memory-cell (row-idx (thread-idx), col-idx (thread-idx))

WHEN "." *> WRITE
WHEN "." *> WRITE
IF NOT write-numbers
IF NOT write-numbers
Line 205: Line 109:
col-idx (thread-idx))
col-idx (thread-idx))
END-IF
END-IF

WHEN "," *> READ
WHEN "," *> READ
IF NOT read-numbers
IF NOT read-numbers
Line 214: Line 118:
col-idx (thread-idx))
col-idx (thread-idx))
END-IF
END-IF

*> LURD (/ is not used as it is mucks up syntax highlighting.)
*> LURD (/ is not used as it is mucks up syntax highlighting.)
WHEN X"5C"
WHEN X"5C"
Line 227: Line 131:
SET down-dir (thread-idx, stack-idx) TO TRUE
SET down-dir (thread-idx, stack-idx) TO TRUE
END-EVALUATE
END-EVALUATE


WHEN "/" *> RULD
WHEN "/" *> RULD
EVALUATE TRUE
EVALUATE TRUE
Line 240: Line 144:
SET up-dir (thread-idx, stack-idx) TO TRUE
SET up-dir (thread-idx, stack-idx) TO TRUE
END-EVALUATE
END-EVALUATE

WHEN "!" *> SKIP
WHEN "!" *> SKIP
PERFORM 100-move-instruction-ptr
PERFORM 100-move-instruction-ptr

WHEN "?" *> SKIPZ
WHEN "?" *> SKIPZ
IF memory-cell (row-idx (thread-idx), col-idx (thread-idx))
IF memory-cell (row-idx (thread-idx), col-idx (thread-idx))
Line 249: Line 153:
PERFORM 100-move-instruction-ptr
PERFORM 100-move-instruction-ptr
END-IF
END-IF

*> Modular SNUSP
*> Modular SNUSP
WHEN "@" *> ENTER
WHEN "@" *> ENTER
Line 256: Line 160:
TO calls (thread-idx, stack-idx + 1)
TO calls (thread-idx, stack-idx + 1)
SET stack-idx UP BY 1
SET stack-idx UP BY 1

WHEN "#" *> LEAVE
WHEN "#" *> LEAVE
IF stack-idx <> 1
IF stack-idx <> 1
Line 266: Line 170:
PERFORM 200-stop-thread
PERFORM 200-stop-thread
END-IF
END-IF

*> Bloated SNUSP
*> Bloated SNUSP
WHEN ":" *> UP
WHEN ":" *> UP
SET row-idx (thread-idx) UP BY 1
SET row-idx (thread-idx) UP BY 1

WHEN ";" *> DOWN
WHEN ";" *> DOWN
SET row-idx (thread-idx) DOWN BY 1
SET row-idx (thread-idx) DOWN BY 1

WHEN "&" *> SPLIT
WHEN "&" *> SPLIT
*> Create a new thread
*> Create a new thread
Line 280: Line 184:
MOVE memory-pointer (thread-idx) TO call-stack (num-threads)
MOVE memory-pointer (thread-idx) TO call-stack (num-threads)
SET thread-started (thread-idx) TO TRUE
SET thread-started (thread-idx) TO TRUE

WHEN "%" *> RAND
WHEN "%" *> RAND
COMPUTE memory-cell (row-idx (thread-idx),
COMPUTE memory-cell (row-idx (thread-idx),
Line 287: Line 191:
memory-cell (row-idx (thread-idx),
memory-cell (row-idx (thread-idx),
col-idx (thread-idx)) + 1)
col-idx (thread-idx)) + 1)
WHEN OTHER
WHEN OTHER
CONTINUE
CONTINUE
END-EVALUATE
END-EVALUATE
IF out-of-code-space
IF out-of-code-space
PERFORM 200-stop-thread
PERFORM 200-stop-thread
Line 323: Line 228:
MOVE threads-data (thread-idx + 1) TO threads-data (thread-idx)
MOVE threads-data (thread-idx + 1) TO threads-data (thread-idx)
END-PERFORM
END-PERFORM
SUBTRACT 1 FROM num-threads
SUBTRACT 1 FROM num-threads
SET thread-idx TO current-thread-idx
SET thread-idx TO current-thread-idx
Line 330: Line 235:
EXIT
EXIT
.
.
END PROGRAM snusp-interpreter.
300-display-help SECTION.

DISPLAY "This is a interpreter for SNUSP written in COBOL."

DISPLAY "The file path to the source code should be specified as a "
IDENTIFICATION DIVISION.
"command-line argument."
PROGRAM-ID. parse-arguments.
DISPLAY "This program supports the following flags as arguments:"

DISPLAY Tab-Char Flag-Indicator Help-Flag-Char ": Displays this help "
DATA DIVISION.
"message."
LOCAL-STORAGE SECTION.
DISPLAY Tab-Char Flag-Indicator Write-Num-Flag-Char ": Display memory "
01 num-args PIC 9 COMP.
"contents as numbers."
01 arg-num PIC 9 COMP.
DISPLAY Tab-Char Flag-Indicator Read-Num-Flag-Char ": Reads a byte to "
"memory as a number."
01 arg PIC X(100).

.
COPY "dd-flag-constants.cpy".
399-exit.

EXIT
01 program-flag PIC X.
88 help-flag VALUE Help-Flag-Char.
88 read-num-flag VALUE Read-Num-Flag-Char.
88 write-num-flag VALUE Write-Num-Flag-Char.

LINKAGE SECTION.
COPY "dd-program-arguments.cpy".

PROCEDURE DIVISION USING program-arguments.
ACCEPT num-args FROM ARGUMENT-NUMBER
IF num-args = 0
CALL "display-help"
STOP RUN
END-IF

PERFORM VARYING arg-num FROM 1 BY 1 UNTIL arg-num > num-args
DISPLAY arg-num UPON ARGUMENT-NUMBER
ACCEPT arg FROM ARGUMENT-VALUE
EVALUATE TRUE
WHEN arg (1:1) = Flag-Indicator
MOVE arg (2:1) TO program-flag
EVALUATE TRUE
WHEN help-flag
CALL "display-help"
STOP RUN
WHEN read-num-flag
SET read-numbers TO TRUE
WHEN write-num-flag
SET write-numbers TO TRUE
WHEN OTHER
DISPLAY "Flag '" FUNCTION TRIM(arg) "' not recongnized."
END-EVALUATE
WHEN code-file-path <> SPACES
DISPLAY "Argument " arg-num " ignored - only one source code "
"file can be interpreted."
WHEN OTHER
MOVE arg TO code-file-path
END-EVALUATE
END-PERFORM
.
.
END PROGRAM snusp-interpreter.</lang>
END PROGRAM parse-arguments.


IDENTIFICATION DIVISION.
PROGRAM-ID. read-code-file.

ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT code-file ASSIGN code-file-path
ORGANIZATION LINE SEQUENTIAL
FILE STATUS code-file-status.
DATA DIVISION.
FILE SECTION.
FD code-file.
01 code-record PIC X(100).
LOCAL-STORAGE SECTION.
01 code-file-status PIC 99.
88 end-of-code-file VALUE 10.

LINKAGE SECTION.
COPY "dd-code-area.cpy".

01 code-file-path PIC X(100).

PROCEDURE DIVISION USING code-file-path, code-area.
DECLARATIVES.
code-file-error SECTION.
USE AFTER ERROR ON code-file.
DISPLAY "An error occurred while using " FUNCTION TRIM(code-file-path)
DISPLAY "Error code " code-file-status
DISPLAY "The program will terminate."
GOBACK
.
END DECLARATIVES.

OPEN INPUT code-file
PERFORM VARYING line-idx FROM 1 BY 1 UNTIL end-of-code-file
ADD 1 TO num-lines
READ code-file INTO code-lines (line-idx)
AT END
SUBTRACT 1 FROM num-lines
EXIT PERFORM
END-READ
END-PERFORM
CLOSE code-file
.
END PROGRAM read-code-file.


IDENTIFICATION DIVISION.
FUNCTION-ID. find-initial.

DATA DIVISION.
LINKAGE SECTION.
COPY "dd-code-area.cpy".

01 instruction-ptr.
03 ip-line USAGE INDEX.
03 ip-char USAGE INDEX.

PROCEDURE DIVISION USING code-area RETURNING instruction-ptr.
PERFORM VARYING ip-line FROM 1 BY 1 UNTIL ip-line > num-lines
AFTER ip-char FROM 1 BY 1 UNTIL ip-char > 100
IF code-chars (ip-line, ip-char) = "$"
EXIT PERFORM
END-IF
END-PERFORM
*> Set position to first char if no initial characters were found.
IF ip-line > num-lines
SET ip-line, ip-char TO 1
END-IF
.
END FUNCTION find-initial.


IDENTIFICATION DIVISION.
PROGRAM-ID. display-help.

DATA DIVISION.
WORKING-STORAGE SECTION.
COPY "dd-flag-constants.cpy".

01 Tab-Char CONSTANT X"09".

PROCEDURE DIVISION.
DISPLAY "This is a interpreter for SNUSP written in COBOL."
DISPLAY "The file path to the source code should be specified as a "
"command-line argument."
DISPLAY "This program supports the following flags as arguments:"
DISPLAY Tab-Char Flag-Indicator Help-Flag-Char ": Displays this help "
"message."
DISPLAY Tab-Char Flag-Indicator Write-Num-Flag-Char ": Display memory "
"contents as numbers."
DISPLAY Tab-Char Flag-Indicator Read-Num-Flag-Char ": Reads a byte to "
"memory as a number."
.
END PROGRAM display-help.</lang>

dd-code-area.cpy:
<lang cobol>01 code-area.
03 num-lines PIC 9(4) COMP.
03 code-lines OCCURS 1 TO 1024 TIMES
DEPENDING ON num-lines
INDEXED BY line-idx.
05 code-chars PIC X OCCURS 100 TIMES.</lang>

dd-flag-constants.cpy:
<lang cobol>01 Flag-Indicator CONSTANT "-".
01 Help-Flag-Char CONSTANT "h".
01 Read-Num-Flag-Char CONSTANT "r".
01 Write-Num-Flag-Char CONSTANT "w".</lang>

dd-programs-arguments.cpy:
<lang cobol>01 program-arguments.
03 code-file-path PIC X(100).
03 read-flag PIC X.
88 read-numbers VALUE "N".
03 write-flag PIC X.
88 write-numbers VALUE "N".</lang>
Retrieved from "https://rosettacode.org/wiki/RCSNUSP/COBOL"