RCSNUSP/COBOL: Difference between revisions

Content added Content deleted
m (Added works with tag.)
(Added support for Bloated SNUSP and added command-line options.)
Line 1: Line 1:
This an SNUSP interpreter written in COBOL. It supports Modular SNUSP but not yet Bloated SNUSP.
This an SNUSP interpreter written in COBOL. It supports Modular and Bloated SNUSP.


The file path to the code is passed as a parameter to the program. The file is assumed to be a text file with lines having a maximum length of 100 characters. It is also assumed the file will not be more than 1024 lines long.
The file path to the code is passed as a parameter to the program. The file is assumed to be a text file with lines having a maximum length of 100 characters. It is also assumed the file will not be more than 1024 lines long.
Line 23: Line 23:


WORKING-STORAGE SECTION.
WORKING-STORAGE SECTION.
01 num-args PIC 9 COMP.
01 arg-num PIC 9 COMP.
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-path PIC X(100).
01 code-file-status PIC 99.
01 code-file-status PIC 99.
Line 32: Line 51:
DEPENDING ON num-lines
DEPENDING ON num-lines
INDEXED BY line-idx.
INDEXED BY line-idx.
05 code-chars PIC X OCCURS 100 TIMES
05 code-chars PIC X OCCURS 100 TIMES.
INDEXED BY char-idx.


01 program-state-flag PIC X VALUE SPACE.
01 program-state-flag PIC X VALUE SPACE.
Line 40: Line 58:
88 out-of-code-space VALUE "O".
88 out-of-code-space VALUE "O".


01 array-area.
01 memory-area.
03 array OCCURS 2048 TIMES
03 memory-rows OCCURS 1024 TIMES.
INDEXED BY table-idx.
05 memory-cols OCCURS 1024 TIMES.
05 array-table USAGE BINARY-CHAR.
07 memory-cell USAGE BINARY-CHAR.
05 array-table-char REDEFINES array-table PIC X.
07 memory-cell-char REDEFINES memory-cell PIC X.


01 num-threads PIC 99 COMP VALUE 1.
01 call-stack-area.
01 threads-data-area.
03 calls OCCURS 512 TIMES INDEXED BY stack-idx.
05 direction PIC X.
03 threads-data OCCURS 1 TO 16 TIMES
88 up-dir VALUE "U".
DEPENDING ON num-threads
88 down-dir VALUE "D".
INDEXED BY thread-idx.
88 left-dir VALUE "L".
05 thread-status-flag PIC X VALUE SPACE.
88 right-dir VALUE "R".
88 thread-started VALUE "Y".
05 ip-line USAGE INDEX.
05 call-stack.
05 ip-char USAGE INDEX.
07 calls OCCURS 512 TIMES
INDEXED BY stack-idx.
09 direction PIC X.
88 up-dir VALUE "U".
88 down-dir VALUE "D".
88 left-dir VALUE "L".
88 right-dir VALUE "R".
09 ip-line USAGE INDEX.
09 ip-char USAGE INDEX.
05 memory-pointer.
07 row-idx USAGE INDEX.
07 col-idx USAGE INDEX.
01 input-char PIC X.
01 input-char PIC X.

01 current-thread-idx USAGE INDEX.


PROCEDURE DIVISION.
PROCEDURE DIVISION.
Line 63: Line 94:
USE AFTER ERROR ON code-file.
USE AFTER ERROR ON code-file.
DISPLAY "An error occurred while using " code-file-path
DISPLAY "An error occurred while using " FUNCTION TRIM(code-file-path)
DISPLAY "Error code " code-file-status
DISPLAY "Error code " code-file-status
DISPLAY "Error triggered at " FUNCTION TRIM(FUNCTION EXCEPTION-LOCATION)
" by " FUNCTION EXCEPTION-STATEMENT "."
DISPLAY "The program will terminate."
DISPLAY "The program will terminate."


Line 74: Line 103:


000-main SECTION.
000-main SECTION.
ACCEPT code-file-path FROM COMMAND-LINE
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
DISPLAY "No file path specified."
GOBACK
END-IF
*> Store contents of file into memory.
*> Store contents of file into memory.
OPEN INPUT code-file
OPEN INPUT code-file
Line 90: Line 155:
*> Search for any initial charcters.
*> Search for any initial charcters.
PERFORM VARYING ip-line (1) FROM 1 BY 1 UNTIL ip-line (1) > num-lines
PERFORM VARYING ip-line (1, 1) FROM 1 BY 1 UNTIL ip-line (1, 1) > num-lines
AFTER ip-char (1) FROM 1 BY 1 UNTIL ip-char (1) > 100
AFTER ip-char (1, 1) FROM 1 BY 1 UNTIL ip-char (1, 1) > 100
IF code-chars (ip-line (1), ip-char (1)) = "$"
IF code-chars (ip-line (1, 1), ip-char (1, 1)) = "$"
EXIT PERFORM
EXIT PERFORM
END-IF
END-IF
END-PERFORM
END-PERFORM
*> Set position to first char if no initial characters were found.
*> Set position to first char if no initial characters were found.
IF ip-line (1) > num-lines
IF ip-line (1, 1) > num-lines
SET line-idx, char-idx TO 1
SET ip-line (1, 1), ip-char (1, 1) TO 1
END-IF
END-IF
*> Interpret the code while the instruction pointer remains in code space.
*> Interpret the code while there are threads left.
SET right-dir (1) TO TRUE
SET right-dir (1, 1) TO TRUE
SET stack-idx TO 1
SET stack-idx, thread-idx, row-idx (1), col-idx (1) TO 1
PERFORM UNTIL NOT program-ok
PERFORM UNTIL num-threads = 0
PERFORM 100-move-instruction-ptr
PERFORM VARYING thread-idx FROM 1 BY 1 UNTIL thread-idx > num-threads
IF out-of-code-space
PERFORM 100-move-instruction-ptr
EXIT PERFORM
IF out-of-code-space
END-IF
PERFORM 200-stop-thread
END-IF
EVALUATE code-chars (ip-line (stack-idx), ip-char (stack-idx))
*> Core SNUSP
EVALUATE code-chars (ip-line (thread-idx, stack-idx),
WHEN ">"
ip-char (thread-idx, stack-idx))
SET table-idx UP BY 1
*> Core SNUSP
WHEN "<" *> LEFT
SET col-idx (thread-idx) DOWN BY 1


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


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


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


WHEN "."
WHEN "." *> WRITE
DISPLAY array-table-char (table-idx)
IF NOT write-numbers
DISPLAY memory-cell-char (row-idx (thread-idx),
col-idx (thread-idx))
ELSE
DISPLAY memory-cell (row-idx (thread-idx),
col-idx (thread-idx))
END-IF


WHEN ","
WHEN "," *> READ
ACCEPT array-table-char (table-idx)
IF NOT read-numbers
ACCEPT memory-cell-char (row-idx (thread-idx),
col-idx (thread-idx))
ELSE
ACCEPT memory-cell (row-idx (thread-idx),
col-idx (thread-idx))
END-IF


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


WHEN "/"
EVALUATE TRUE
WHEN up-dir (stack-idx)
SET right-dir (stack-idx) TO TRUE
WHEN down-dir (stack-idx)
SET left-dir (stack-idx) TO TRUE
WHEN left-dir (stack-idx)
SET down-dir (stack-idx) TO TRUE
WHEN right-dir (stack-idx)
SET up-dir (stack-idx) TO TRUE
END-EVALUATE
WHEN "!"
PERFORM 100-move-instruction-ptr
WHEN "?"
IF array-table (table-idx) = 0
PERFORM 100-move-instruction-ptr
END-IF


*> Modular SNUSP
WHEN "/" *> RULD
WHEN "@"
EVALUATE TRUE
*> Push current direction and IP location onto call stack
WHEN up-dir (thread-idx, stack-idx)
MOVE calls (stack-idx) TO calls (stack-idx + 1)
SET right-dir (thread-idx, stack-idx) TO TRUE
SET stack-idx UP BY 1
WHEN down-dir (thread-idx, stack-idx)
SET left-dir (thread-idx, stack-idx) TO TRUE
WHEN "#"
WHEN left-dir (thread-idx, stack-idx)
IF stack-idx <> 1
SET down-dir (thread-idx, stack-idx) TO TRUE
*> Pop direction and IP location off call stack and advance
WHEN right-dir (thread-idx, stack-idx)
*> the IP one step.
SET up-dir (thread-idx, stack-idx) TO TRUE
SET stack-idx DOWN BY 1
END-EVALUATE

WHEN "!" *> SKIP
PERFORM 100-move-instruction-ptr
PERFORM 100-move-instruction-ptr
ELSE
SET empty-stack TO TRUE
END-IF


*> Bloated SNUSP
WHEN "?" *> SKIPZ
IF memory-cell (row-idx (thread-idx), col-idx (thread-idx))
WHEN OTHER
= 0
CONTINUE
PERFORM 100-move-instruction-ptr
END-EVALUATE
END-IF
END-PERFORM


*> Modular SNUSP
WHEN "@" *> ENTER
*> Push current direction and IP location onto call stack
MOVE calls (thread-idx, stack-idx)
TO calls (thread-idx, stack-idx + 1)
SET stack-idx UP BY 1

WHEN "#" *> LEAVE
IF stack-idx <> 1
*> Pop direction and IP location off call stack and
*> advance the IP one step.
SET stack-idx DOWN BY 1
PERFORM 100-move-instruction-ptr
ELSE
PERFORM 200-stop-thread
END-IF

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

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

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

WHEN "%" *> RAND
COMPUTE memory-cell (row-idx (thread-idx),
col-idx (thread-idx)) =
FUNCTION MOD(FUNCTION RANDOM,
memory-cell (row-idx (thread-idx),
col-idx (thread-idx)) + 1)
WHEN OTHER
CONTINUE
END-EVALUATE
IF out-of-code-space
PERFORM 200-stop-thread
END-IF
END-PERFORM
END-PERFORM
.
099-terminate.
GOBACK
GOBACK
.
.
100-move-instruction-ptr SECTION.
100-move-instruction-ptr SECTION.
EVALUATE TRUE
EVALUATE TRUE
WHEN up-dir (stack-idx)
WHEN up-dir (thread-idx, stack-idx)
SET ip-line (stack-idx) DOWN BY 1
SET ip-line (thread-idx, stack-idx) DOWN BY 1
WHEN down-dir (stack-idx)
WHEN down-dir (thread-idx, stack-idx)
SET ip-line (stack-idx) UP BY 1
SET ip-line (thread-idx, stack-idx) UP BY 1
WHEN left-dir (stack-idx)
WHEN left-dir (thread-idx, stack-idx)
SET ip-char (stack-idx) DOWN BY 1
SET ip-char (thread-idx, stack-idx) DOWN BY 1
WHEN right-dir (stack-idx)
WHEN right-dir (thread-idx, stack-idx)
SET ip-char (stack-idx) UP BY 1
SET ip-char (thread-idx, stack-idx) UP BY 1
END-EVALUATE
END-EVALUATE
.
199-exit.
EXIT
.
200-stop-thread SECTION.
*> Shift data from following threads over stopped thread.
SET current-thread-idx TO thread-idx
PERFORM VARYING thread-idx FROM thread-idx BY 1
UNTIL NOT thread-started (thread-idx + 1)
OR thread-idx = num-threads
MOVE threads-data (thread-idx + 1) TO threads-data (thread-idx)
END-PERFORM
SUBTRACT 1 FROM num-threads
SET thread-idx TO current-thread-idx
.
299-exit.
EXIT
.
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 "
"command-line argument."
DISPLAY "This program supports the following flags as arguments:"
DISPLAY X"09" Flag-Indicator Help-Flag-Char ": Displays this help message."
DISPLAY X"09" Flag-Indicator Write-Num-Flag-Char ": Display memory "
"contents as numbers."
DISPLAY X"09" Flag-Indicator Read-Num-Flag-Char ": Reads a byte to memory "
"as a number."
.
399-exit.
EXIT
.
.
END PROGRAM snusp-interpreter.</lang>
END PROGRAM snusp-interpreter.</lang>
Retrieved from "https://rosettacode.org/wiki/RCSNUSP/COBOL"