74 lines
2 KiB
Text
74 lines
2 KiB
Text
100H:
|
|
|
|
/* COPY A STRING (MINUS TERMINATOR), RETURNS LENGTH (MINUS TERMINATOR) */
|
|
COPY$STR: PROCEDURE(SRC, DST) ADDRESS;
|
|
DECLARE (SRC, DST) ADDRESS;
|
|
DECLARE (SCH BASED SRC, DCH BASED DST) BYTE;
|
|
DECLARE L ADDRESS;
|
|
L = 0;
|
|
DO WHILE SCH <> '$';
|
|
DCH = SCH;
|
|
SRC = SRC + 1;
|
|
DST = DST + 1;
|
|
L = L + 1;
|
|
END;
|
|
RETURN L;
|
|
END COPY$STR;
|
|
|
|
/* QUIBBLE GIVEN ARRAY OF $-TERMINATED STRINGS, STORE RESULT IN BUFR */
|
|
QUIBBLE: PROCEDURE(WORDS, BUFR) ADDRESS;
|
|
DECLARE (WORDS, BUFR, ADR) ADDRESS;
|
|
DECLARE (WORD BASED WORDS, WPTR) ADDRESS;
|
|
DECLARE (WCHAR BASED WPTR, BCHAR BASED BUFR) BYTE;
|
|
|
|
/* BRACES AND LOWERCASE LETTERS ARE NOT WITHIN PL/M CHARSET */
|
|
DECLARE LBRACE LITERALLY '123', RBRACE LITERALLY '125';
|
|
DECLARE ANDSTR DATA (32,97,110,100,32,'$');
|
|
|
|
ADR = BUFR;
|
|
BCHAR = LBRACE;
|
|
BUFR = BUFR + 1;
|
|
DO WHILE WORD <> 0;
|
|
BUFR = BUFR + COPY$STR(WORD, BUFR);
|
|
WORDS = WORDS + 2;
|
|
IF WORD <> 0 THEN
|
|
IF WORD(1) <> 0 THEN
|
|
BUFR = BUFR + COPY$STR(.', $', BUFR);
|
|
ELSE
|
|
BUFR = BUFR + COPY$STR(.ANDSTR, BUFR);
|
|
END;
|
|
BCHAR = RBRACE;
|
|
BUFR = BUFR + 1;
|
|
BCHAR = '$';
|
|
RETURN ADR;
|
|
END QUIBBLE;
|
|
|
|
/* --- CP/M OUTPUT AND TESTING --- */
|
|
BDOS: PROCEDURE(FUNC, ARG); /* MAKE CP/M SYSTEM CALL */
|
|
DECLARE FUNC BYTE, ARG ADDRESS;
|
|
GO TO 5;
|
|
END BDOS;
|
|
|
|
DECLARE BDOS$EXIT LITERALLY '0', /* EXIT TO CP/M */
|
|
BDOS$PUTS LITERALLY '9'; /* PRINT STRING */
|
|
|
|
PUTS: PROCEDURE(S);
|
|
DECLARE S ADDRESS;
|
|
CALL BDOS(BDOS$PUTS, S);
|
|
CALL BDOS(BDOS$PUTS, .(13,10,'$'));
|
|
END PUTS;
|
|
|
|
/* ARRAY WITH INITIALLY NO CONTENTS */
|
|
DECLARE ARR (5) ADDRESS INITIAL (0,0,0,0,0);
|
|
|
|
CALL PUTS(QUIBBLE(.ARR, .MEMORY)); /* NO STRINGS */
|
|
ARR(0) = .'ABC$';
|
|
CALL PUTS(QUIBBLE(.ARR, .MEMORY)); /* ABC */
|
|
ARR(1) = .'DEF$';
|
|
CALL PUTS(QUIBBLE(.ARR, .MEMORY)); /* ABC AND DEF */
|
|
ARR(2) = .'G$';
|
|
ARR(3) = .'H$';
|
|
CALL PUTS(QUIBBLE(.ARR, .MEMORY)); /* ABC, DEF, G AND H */
|
|
|
|
CALL BDOS(BDOS$EXIT, 0);
|
|
EOF
|