RCSNUSP/COBOL
This an SNUSP interpreter written in COBOL. It supports Modular SNUSP but not yet 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 memory is a 2048 byte array and the stack has a size of 512.
<lang cobol> >>SOURCE FREE IDENTIFICATION DIVISION. PROGRAM-ID. snusp-interpreter.
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).
WORKING-STORAGE SECTION. 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 INDEXED BY char-idx.
01 program-state-flag PIC X VALUE SPACE.
88 program-ok VALUE SPACE. 88 empty-stack VALUE "E". 88 out-of-code-space VALUE "O".
01 array-area.
03 array OCCURS 2048 TIMES INDEXED BY table-idx. 05 array-table USAGE BINARY-CHAR. 05 array-table-char REDEFINES array-table PIC X.
01 call-stack-area.
03 calls OCCURS 512 TIMES INDEXED BY stack-idx. 05 direction PIC X. 88 up-dir VALUE "U". 88 down-dir VALUE "D". 88 left-dir VALUE "L". 88 right-dir VALUE "R". 05 ip-line USAGE INDEX. 05 ip-char USAGE INDEX.
01 input-char PIC X.
PROCEDURE DIVISION. DECLARATIVES. code-file-error SECTION.
USE AFTER ERROR ON code-file. DISPLAY "An error occurred while using " 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."
GOBACK .
END DECLARATIVES.
000-main SECTION.
ACCEPT code-file-path FROM COMMAND-LINE
*> 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
CLOSE code-file *> Search for any initial charcters. PERFORM VARYING ip-line (1) FROM 1 BY 1 UNTIL ip-line (1) > num-lines AFTER ip-char (1) FROM 1 BY 1 UNTIL ip-char (1) > 100 IF code-chars (ip-line (1), ip-char (1)) = "$" EXIT PERFORM END-IF END-PERFORM *> Set position to first char if no initial characters were found. IF ip-line (1) > num-lines SET line-idx, char-idx TO 1 END-IF *> Interpret the code while the instruction pointer remains in code space. SET right-dir (1) TO TRUE SET stack-idx TO 1 PERFORM UNTIL NOT program-ok PERFORM 100-move-instruction-ptr IF out-of-code-space EXIT PERFORM END-IF EVALUATE code-chars (ip-line (stack-idx), ip-char (stack-idx)) *> Core SNUSP WHEN ">" SET table-idx UP BY 1
WHEN "<" SET table-idx DOWN BY 1
WHEN "+" ADD 1 TO array-table (table-idx)
WHEN "-" SUBTRACT 1 FROM array-table (table-idx)
WHEN "." DISPLAY array-table-char (table-idx)
WHEN "," ACCEPT array-table-char (table-idx)
WHEN X"5C" *> Backslash mucks up syntax highlighting EVALUATE TRUE WHEN up-dir (stack-idx) SET left-dir (stack-idx) TO TRUE WHEN down-dir (stack-idx) SET right-dir (stack-idx) TO TRUE WHEN left-dir (stack-idx) SET up-dir (stack-idx) TO TRUE WHEN right-dir (stack-idx) SET down-dir (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 "@" *> Push current direction and IP location onto call stack MOVE calls (stack-idx) TO calls (stack-idx + 1) SET stack-idx UP BY 1 WHEN "#" 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 SET empty-stack TO TRUE END-IF
*> Bloated SNUSP WHEN OTHER CONTINUE END-EVALUATE END-PERFORM
GOBACK .
100-move-instruction-ptr SECTION.
EVALUATE TRUE WHEN up-dir (stack-idx) SET ip-line (stack-idx) DOWN BY 1 WHEN down-dir (stack-idx) SET ip-line (stack-idx) UP BY 1 WHEN left-dir (stack-idx) SET ip-char (stack-idx) DOWN BY 1 WHEN right-dir (stack-idx) SET ip-char (stack-idx) UP BY 1 END-EVALUATE .
END PROGRAM snusp-interpreter.</lang>