Rosetta Code

RCSNUSP/COBOL: Difference between revisions

Page Discussion

RCSNUSP/COBOL (view source)

Revision as of 18:44, 23 December 2013

6,127 bytes added ,  10 years ago
Added support for Bloated SNUSP and added command-line options.
m (Added works with tag.)
(Added support for Bloated SNUSP and added command-line options.)
Line 1:
This an SNUSP interpreter written in COBOL. It supports Modular SNUSP but not yetand 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.
Line 23:
 
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-status PIC 99.
Line 32 ⟶ 51:
DEPENDING ON num-lines
INDEXED BY line-idx.
05 code-chars PIC X OCCURS 100 TIMES.
INDEXED BY char-idx.
 
01 program-state-flag PIC X VALUE SPACE.
Line 40 ⟶ 58:
88 out-of-code-space VALUE "O".
 
01 arraymemory-area.
03 array memory-rows OCCURS 20481024 TIMES.
05 memory-cols OCCURS 1024 INDEXED BY table-idxTIMES.
05 array-table 07 memory-cell USAGE BINARY-CHAR.
05 array-table-char 07 memory-cell-char REDEFINES arraymemory-tablecell 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.
03 threads-data 05 direction OCCURS 1 TO PIC16 X.TIMES
88 up-dir VALUE "U". DEPENDING ON num-threads
88 down-dir VALUE "D" INDEXED BY thread-idx.
05 88 leftthread-dir status-flag PIC X VALUE "L"SPACE.
88 rightthread-dir started VALUE "RY".
05 ipcall-line USAGE INDEXstack.
05 ip-char 07 calls USAGE INDEX. 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 current-thread-idx USAGE INDEX.
 
PROCEDURE DIVISION.
Line 63 ⟶ 94:
USE AFTER ERROR ON code-file.
DISPLAY "An error occurred while using " FUNCTION TRIM(code-file-path)
DISPLAY "Error code " code-file-status
DISPLAY "Error triggered at " FUNCTION TRIM(FUNCTION EXCEPTION-LOCATION)
" by " FUNCTION EXCEPTION-STATEMENT "."
DISPLAY "The program will terminate."
 
Line 74 ⟶ 103:
 
000-main SECTION.
ACCEPT codenum-file-pathargs FROM COMMANDARGUMENT-LINENUMBER
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.
OPEN INPUT code-file
Line 90 ⟶ 155:
*> Search for any initial charcters.
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 lineip-idxline (1, char1), ip-idxchar (1, 1) TO 1
END-IF
*> Interpret the code while thethere instructionare pointerthreads remains in code spaceleft.
SET right-dir (1, 1) TO TRUE
SET stack-idx, thread-idx, row-idx (1), col-idx (1) TO 1
PERFORM UNTIL NOT programnum-okthreads = 0
PERFORM 100VARYING thread-moveidx FROM 1 BY 1 UNTIL thread-instructionidx > num-ptrthreads
IF out PERFORM 100-ofmove-codeinstruction-spaceptr
EXITIF PERFORMout-of-code-space
END PERFORM 200-IFstop-thread
END-IF
EVALUATE code-chars (ip-line (stack-idx), ip-char (stack-idx))
*>EVALUATE Corecode-chars SNUSP(ip-line (thread-idx, stack-idx),
WHEN ">" ip-char (thread-idx, stack-idx))
SET*> table-idxCore UP BY 1SNUSP
WHEN "<" *> LEFT
SET col-idx (thread-idx) DOWN BY 1
 
WHEN "<>" *> RIGHT
SET tablecol-idx (thread-idx) DOWNUP BY 1
 
WHEN "+" *> INCR
ADD 1 TO array-table (table-idx)
memory-cell (row-idx (thread-idx), col-idx (thread-idx))
 
WHEN "-" *> DECR
SUBTRACT 1 FROM array-table (table-idx)
memory-cell (row-idx (thread-idx), col-idx (thread-idx))
 
WHEN "." *> WRITE
DISPLAY array-table-char (table IF NOT write-idx)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 "," *> READ
ACCEPT array-table-char (table IF NOT read-idx)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" *> BackslashLURD (/ is not used as it is mucks up syntax highlighting.)
EVALUATEWHEN TRUEX"5C"
WHENEVALUATE up-dir (stack-idx)TRUE
SETWHEN leftup-dir (thread-idx, stack-idx) TO TRUE
WHEN down SET left-dir (thread-idx, stack-idx) TO TRUE
SETWHEN rightdown-dir (thread-idx, stack-idx) TO TRUE
WHEN left SET right-dir (thread-idx, stack-idx) TO TRUE
SETWHEN upleft-dir (thread-idx, stack-idx) TO TRUE
WHEN right SET up-dir (thread-idx, stack-idx) TO TRUE
SETWHEN downright-dir (thread-idx, stack-idx) TO TRUE
END SET down-EVALUATEdir (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
 
WHEN "/" *> Modular SNUSPRULD
WHEN "@" EVALUATE TRUE
*> Push current direction and IP location onto callWHEN up-dir (thread-idx, stack-idx)
MOVE calls (stack-idx) TO calls SET right-dir (thread-idx, stack-idx) +TO 1)TRUE
SET stack-idx UP BY 1 WHEN down-dir (thread-idx, stack-idx)
SET left-dir (thread-idx, stack-idx) TO TRUE
WHEN "#"left-dir (thread-idx, stack-idx)
IF SET down-dir (thread-idx, stack-idx) <>TO 1TRUE
*> Pop direction and IPWHEN locationright-dir off call(thread-idx, stack and advance-idx)
*> the IP one step. SET up-dir (thread-idx, stack-idx) TO TRUE
SET stackEND-idx DOWN BY 1EVALUATE
 
WHEN "!" *> SKIP
PERFORM 100-move-instruction-ptr
ELSE
SET empty-stack TO TRUE
END-IF
 
WHEN "?" *> Bloated SNUSPSKIPZ
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
.
100-move-instruction-ptr SECTION.
EVALUATE TRUE
WHEN up-dir (thread-idx, stack-idx)
SET ip-line (thread-idx, stack-idx) DOWN BY 1
WHEN down-dir (thread-idx, stack-idx)
SET ip-line (thread-idx, stack-idx) UP BY 1
WHEN left-dir (thread-idx, stack-idx)
SET ip-char (thread-idx, stack-idx) DOWN BY 1
WHEN right-dir (thread-idx, stack-idx)
SET ip-char (thread-idx, stack-idx) UP BY 1
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>
Anonymous user
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/237621"