Topic: Next Topic Title: How about computer software (42381 bytes worth) Author: EISNER::KILGALLEN "Larry Kilgallen, LJK Software" Note: 2.2, (2 of 9) , Created: 9-MAR-1995 10:34, 1398 Lines I recently posted some to DECUServe but nobody has reviewed it. If you think this is inappropriate in a Baseball topic, and you are a moderator, you should move it rather than chastize me, since I presume that chastize works fine on any product which claims Internet compatibility. MODULE MEMO_STORAGE (IDENT = 'V2.0', LIST(EXPAND,TRACE), ADDRESSING_MODE (EXTERNAL = GENERAL), MAIN = MEMO_STORAGE) = BEGIN LIBRARY 'SYS$LIBRARY:STARLET'; ! .title memo_storage ;memo.mar ! .ident "V1.1" !; !; Digital Equipment Computer Users Society (DECUS) !; This program may be freely distributed or modified by any party, including !; but not limited to DECUS and anyone within DECUS. !; USE AT YOUR OWN RISK !; DECUS, DECUServe and the author make NO warranties whatsoever, including !; without limitation, all implied warranties of merchantability and fitness. !; !; Author: Jack Harvey October 14, 1991 ! ! Edit history: ! ! 1-Feb-1995 LJK Corrected handling of MEMO_STORAGE_PROTECTED symbol, ! which apparently did not work in Macro version. ! ! 31-Jan-1995 LJK Converted to Bliss for AXP compatibility ! The converted program emulates the Macro-32 ! coding style, for the sake of compatibility, ! rather than exhibiting good Bliss coding ! style. - Larry Kilgallen ! ! $acldef ! $acedef ! !; Simple macro to pass arguments needed here to LIB$GET_SYMBOL ! .macro get_symbol sym,equ,len ! pushal len ;resulting length returned here ! pushal equ ;equivilent string goes here ! pushal sym ;symbol wanted ! calls #3,G^lib$get_symbol ! .endm get_symbol MACRO GET_SYMBOL ( SYM, EQU, LEN ) = BEGIN LIB$GET_SYMBOL ( %NAME ( 'MEMO_R_', SYM ), ! Name of DCL symbol %NAME ( 'MEMO_R_', EQU ), ! Symbol value LEN ) ! Value length END%; !; Simple macro to pass arguments needed here to LIB$SET_SYMBOL ! .macro set_symbol sym,equ ! pushal equ ;equivilent string goes here ! pushal sym ;symbol to create ! calls #2,G^lib$set_symbol ! .endm set_symbol MACRO SET_SYMBOL ( SYM, EQU ) = BEGIN LIB$SET_SYMBOL ( %NAME ( 'MEMO_R_', SYM ), ! Name of DCL symbol %NAME ( 'MEMO_R_', EQU ) ) ! Value of symbol END%; !; Macro to aid coding error message display ! .macro error descrip ! pushal descrip ! brw errormsg ! .endm error MACRO ERROR ( DESCRIP ) = BEGIN ERRORMSG ( %NAME ( 'MEMO_R_', DESCRIP ) ); ! Name of error END%; ! ! VMS status not available from STARLET.REQ ! EXTERNAL LITERAL LIB$_NOSUCHSYM; ! ! VMS Run-Time Library routines ! EXTERNAL ROUTINE OTS$CVT_TI_L, OTS$CVT_L_TI, LIB$GET_SYMBOL, LIB$SET_SYMBOL, LIB$CVT_DTB, LIB$PUT_OUTPUT, LIB$GET_FOREIGN; ! ! Routines within this program ! FORWARD ROUTINE GETWORD : NOVALUE, SYMBOLS : NOVALUE, OFFLEN : NOVALUE, OFFL : NOVALUE, GET : NOVALUE, PUT : NOVALUE, DIG10 : NOVALUE, DECIMALI : NOVALUE, HEXBIN : NOVALUE, ASCIIO : NOVALUE, DECIMALO : NOVALUE, HEXER : NOVALUE, HEXIT : NOVALUE, UPDATE, BINIT, SYMCHK : NOVALUE, LOADACE : NOVALUE, GETACE, ERRORMSG : NOVALUE; ! CTRL/L goes here !.psect memo_storage_data noexe,wrt,pic,noshr,long ! !;This is a generic header, customized at 'target' for our particular ACE !acehed: .byte 32,ace$c_info ;Declaring the kind of ACE ! .word ace$c_cust!ace$m_protected;and its charactistics. !target: .blkb 8 ;Name bytes for wanted ACE !hedsiz = .-acehed LITERAL MEMO_S_TARGET = 8; ! Name bytes size OWN MEMO_R_ACEHED : $BBLOCK [($BYTEOFFSET(ACE$L_INFO_FLAGS))+MEMO_S_TARGET] ! PRESET ( ! [ACE$B_SIZE] = 32, ! Declaring the kind of ACE [ACE$B_TYPE] = ACE$C_INFO, ! Declaring the kind of ACE [ACE$V_INFO_TYPE] = ACE$C_CUST, ! and its charactistics. [ACE$V_PROTECTED] = 1); ! and its charactistics. LITERAL MEMO_S_HEDSIZ = %ALLOCATION(MEMO_R_ACEHED); ! !tbytes = 200 ;maximum amount of storage to provide LITERAL MEMO_S_TBYTES = 200, ! maximum amount of storage to provide MEMO_S_BUFSIZ = MEMO_S_HEDSIZ+MEMO_S_TBYTES; !;Used to access the ACL of the object file. !itmlst: .word bufsiz ;item list for accessing the ACE !cmd: .word acl$c_readacl ! .address inbuf ! .long 0,0 !inbuf: .blkb 4 ;storage header goes here !acename:.blkb 8 ;should equal "target" !memo: .blkb tbytes ;stored data in this buffer !bufsiz = .-inbuf ! .blkb 3 ;space for sign extention OWN MEMO_R_INBUF : $BBLOCK [MEMO_S_HEDSIZ+MEMO_S_TBYTES], ! storage header goes here MEMO_R_ITMLST : $ITMLST_DECL (ITEMS = 1) PRESET ( [0, ITM$W_BUFSIZ] = 4, ! [0, ITM$W_ITMCOD] = ACL$C_READACL, ! [0, ITM$L_BUFADR] = MEMO_R_INBUF, ! [0, ITM$L_RETLEN] = 0); !contxt: .long 0 ;context variable for ACE search ! !errdspl:.quad 0 ;used for error messages ! !idtext: .word 8,0 ;descriptor for name string ! .address target !idlen: .long 0 ;length of the target name string OWN MEMO_L_CONTXT : INITIAL (0), ! context variable for ACE search MEMO_R_ERRDSPL : VECTOR [2,LONG] INITIAL (0,0), MEMO_L_IDLEN : INITIAL (0), MEMO_R_IDTEXT : $BBLOCK [8] PRESET ( ! [DSC$W_LENGTH] = MEMO_S_TARGET, [DSC$A_POINTER] = MEMO_R_ACEHED [ACE$L_INFO_FLAGS]); !file: .word 256,0 ;descriptor for filename string ! .address filetext !filetext:.blkb 256 OWN MEMO_T_FILETEXT : VECTOR [256,BYTE], MEMO_R_FILE : $BBLOCK [8] PRESET ( ! [DSC$W_LENGTH] = %ALLOCATION (MEMO_T_FILETEXT), [DSC$A_POINTER] = MEMO_T_FILETEXT); !dellst: .word 0 ;ACE deletion item list ! .word acl$c_delaclent ! .address delbuf ! .long 0,0 !delbuf: .blkb hedsiz+tbytes ;exact copy of old ACE for deletion OWN MEMO_R_DELBUF : $BBLOCK [MEMO_S_HEDSIZ+MEMO_S_TBYTES], ! storage header goes here MEMO_R_DELLST : $ITMLST_DECL (ITEMS = 1) PRESET ( [0, ITM$W_BUFSIZ] = 0, ! [0, ITM$W_ITMCOD] = ACL$C_DELACLENT, ! [0, ITM$L_BUFADR] = MEMO_R_DELBUF, ! [0, ITM$L_RETLEN] = 0); ! CTRL/L goes here !;used to access MEMO_STORAGE_PROTECTED symbol !protext:.ascid / / ;Protection symbol returned here. !protval: .address protext+8 ; text = FALS if protected status turned off !protlen:.long 0 ;length of the protection control string OWN MEMO_T_PROTEXT : VECTOR [12,BYTE], ! Protection symbol returned here. MEMO_R_PROTEXT : $BBLOCK [8] PRESET ( ! descriptor for Protection symbol [DSC$W_LENGTH] = %ALLOCATION (MEMO_T_PROTEXT), [DSC$A_POINTER] = MEMO_T_PROTEXT), MEMO_A_PROTVAL : INITIAL (MEMO_T_PROTEXT+8), ! text = FALS if protected status turned off MEMO_L_PROTLEN : INITIAL (0); ! length of the protection control string !vallst: .word tbytes*2,0 ;descriptor for returned value string ! .address hexvals !hexvals:.blkb tbytes * 2 ;hex values go here OWN MEMO_T_HEXVALS : VECTOR [MEMO_S_TBYTES*2, BYTE], ! hex values go here MEMO_R_VALLST : $BBLOCK [8] PRESET ( ! descriptor for returned value string [DSC$W_LENGTH] = %ALLOCATION (MEMO_T_HEXVALS), [DSC$A_POINTER] = MEMO_T_HEXVALS); !;This is for the foreign command processing. !cmdlinesiz=255 !cmddesc:.word cmdlinesiz ;descriptor for command line ! .word 0 ! .address cmdtext !cmdtext:.blkb cmdlinesiz ;text on command line, if any !cmdlen: .word 0 ;length of foreign command found !remlen: .word 0 ;remaining length of foreign command !remtext:.address cmdtext ;pointer to remaining text LITERAL MEMO_S_CMDLINESIZ = 255; OWN MEMO_T_CMDTEXT : VECTOR [MEMO_S_CMDLINESIZ,BYTE], ! text on command line, if any MEMO_R_CMDDESC : $BBLOCK [8] PRESET ( ! descriptor for command line [DSC$W_LENGTH] = %ALLOCATION (MEMO_T_CMDTEXT), [DSC$A_POINTER] = MEMO_T_CMDTEXT), MEMO_W_CMDLEN : INITIAL (0), ! length of foreign command found MEMO_W_REMLEN : INITIAL (0), ! remaining length of foreign command MEMO_A_REMTEXT : INITIAL (MEMO_T_CMDTEXT); ! pointer to remaining text !;The following is a descriptor of a word in the command line !lword: .word 0,0 ;length of command line word found !pword: .long 0 ;pointer to start of command line word OWN MEMO_R_WORD : $BBLOCK [8] PRESET ( ! [DSC$W_LENGTH] = 0, [DSC$A_POINTER] = 0); !length: .long 0 ;length of the data segment !offset: .long 0 ;offset from start of the ACL data !lr: .byte ^A/R/ ;left to right or right to left OWN MEMO_L_LENGTH : INITIAL (0), ! length of the data segment MEMO_L_OFFSET : INITIAL (0), ! offset from start of the ACL data MEMO_B_LR : BYTE INITIAL (%CHAR('R')); ! left to right or right to left !insym: .word tbytes,0 ;descriptor for incoming symbol ! .address intext !intext: .blkb tbytes ;equiv text stored here !inlen: .long 0 ;length of equiv text OWN MEMO_T_INTEXT : VECTOR [MEMO_S_TBYTES, BYTE], ! equiv text stored here MEMO_R_INSYM : $BBLOCK [8] PRESET ( ! descriptor for incoming symbol [DSC$W_LENGTH] = %ALLOCATION (MEMO_T_INTEXT), [DSC$A_POINTER] = MEMO_T_INTEXT), MEMO_L_INLEN : INITIAL (0); !;Used for decimal data output conversion. !dtext: .ascid / / ;longword to ascii translated !dval: .long 0 OWN MEMO_T_DTEXT : VECTOR [11,BYTE] ! longword to ascii translated INITIAL (REP 11 OF BYTE (%CHAR(' '))), MEMO_R_DTEXT : $BBLOCK [8] PRESET ( ! descriptor for ascii translated [DSC$W_LENGTH] = %ALLOCATION (MEMO_T_DTEXT), [DSC$A_POINTER] = MEMO_T_DTEXT), MEMO_L_DVAL : INITIAL (0); ! CTRL/L goes here !;Texts !; DCL symbols for control and data passing BIND !filesym:.ascid /MEMO_STORAGE_FILE/ ;file to which the ACE is applied MEMO_R_FILESYM = $DESCRIPTOR('MEMO_STORAGE_FILE'), !name: .ascid /MEMO_STORAGE_NAME/ ;8 character ACE name MEMO_R_NAME = $DESCRIPTOR('MEMO_STORAGE_NAME'), !PROT: .ascid /MEMO_STORAGE_PROTECTED/ ;if = FALSE, ACE not protected. MEMO_R_PROT = $DESCRIPTOR('MEMO_STORAGE_PROTECTED'); ! !; Special error message texts to sys$output BIND !msg1: .ascid /%MEMO-F-OFFSYM - Symbol for offset or length not found/ MEMO_R_MSG1 = $DESCRIPTOR('%MEMO-F-OFFSYM - Symbol for offset or length not found'), !msg2: .ascid /%MEMO-F-NOTHEX - Invalid hexadecimal character found/ MEMO_R_MSG2 = $DESCRIPTOR('%MEMO-F-NOTHEX - Invalid hexadecimal character found'), !msg3: .ascid /%MEMO-F-INVCMD -Invalid command/ MEMO_R_MSG3 = $DESCRIPTOR('%MEMO-F-INVCMD -Invalid command'), !msg4: .ascid /%MEMO-F-NOCMD - No foreign command line found/ MEMO_R_MSG4 = $DESCRIPTOR('%MEMO-F-NOCMD - No foreign command line found'), !msg5: .ascid /%MEMO-F-NAME - MEMO_STORAGE_NAME incorrectly defined/ MEMO_R_MSG5 = $DESCRIPTOR('%MEMO-F-NAME - MEMO_STORAGE_NAME incorrectly defined'), !msg6: .ascid /%MEMO-F-FILE - MEMO_STORAGE_FILE symbol not defined/ MEMO_R_MSG6 = $DESCRIPTOR('%MEMO-F-FILE - MEMO_STORAGE_FILE symbol not defined'), !msg7: .ascid /%MEMO-F-NODATA - Command line data operand missing/ MEMO_R_MSG7 = $DESCRIPTOR('%MEMO-F-NODATA - Command line data operand missing'), !msg8: .ascid /%MEMO-F-TOOBIG - Offset + length exceeds storage area size/ MEMO_R_MSG8 = $DESCRIPTOR('%MEMO-F-TOOBIG - Offset + length exceeds storage area size'), !msg9: .ascid /%MEMO-F-BADCHR - Invalid character in decimal number/ MEMO_R_MSG9 = $DESCRIPTOR('%MEMO-F-BADCHR - Invalid character in decimal number'), !msg10: .ascid /%MEMO-F-BIGSYM - Hexadecimal data too large for symbol/ MEMO_R_MSG10 = $DESCRIPTOR('%MEMO-F-BIGSYM - Hexadecimal data too large for symbol'), !msg11: .ascid /%MEMO-F-BADDEC - Invalid length for decimal value/ MEMO_R_MSG11 = $DESCRIPTOR('%MEMO-F-BADDEC - Invalid length for decimal value'), !msg12: .ascid /%MEMO-F-BADTYPE - Invalid data radix or format/ MEMO_R_MSG12 = $DESCRIPTOR('%MEMO-F-BADTYPE - Invalid data radix or format'), !msg13: .ascid /%MEMO-F-BADMODE - Transfer mode must be Symbol on GET/ MEMO_R_MSG13 = $DESCRIPTOR('%MEMO-F-BADMODE - Transfer mode must be Symbol on GET'), !msg14: .ascid /%MEMO-F-VALSYM - Symbol for transfer value not found/ MEMO_R_MSG14 = $DESCRIPTOR('%MEMO-F-VALSYM - Symbol for transfer value not found'), !msg15: .ascid /%MEMO-F-NGMODE - Transfer mode not Literal or Symbol/ MEMO_R_MSG15 = $DESCRIPTOR('%MEMO-F-NGMODE - Transfer mode not Literal or Symbol'); ! .end memo_storage !check_status: ;report an error status message to sys$output and quit ! cmpl R0,#SS$_NORMAL ;normal successful completion? ! beql 50$ ;just exit if normal ! movl #1,errdspl ;setup for error display ! movl R0,errdspl+4 ! $putmsg_s msgvec = errdspl ;display error text to terminal ! $exit_s ;abort job ! !50$: rsb ;no error, just return MACRO CHECK_STATUS ( VALUE_SOURCE ) = BEGIN LOCAL VALUE : INITIAL ( VALUE_SOURCE ); IF .VALUE EQL SS$_NORMAL THEN .VALUE ELSE BEGIN MEMO_R_ERRDSPL [0] = 1; MEMO_R_ERRDSPL [1] = .VALUE; $PUTMSG ( MSGVEC = MEMO_R_ERRDSPL ); $EXIT (CODE=SS$_NORMAL) ! Return success, like original END END%; ! CTRL/L goes here !.psect memo_storage_code exe,nowrt,pic,shr,long ! !;Foreign Command entry point as a free-standing program. !.entry memo_storage ^M<> ! pushal cmdlen ;size of returned argument ! clrl -(SP) ;null argument for prompt ! pushal cmddesc ;command line descriptor ! calls #3,G^lib$get_foreign ;get the foreign line command ! bsbw check_status ;exit with message if error ! movw cmdlen,remlen ;copy length for word scan ! bneq 5$ ;br if command string present ! error msg4 ;no foreign command !5$: cmpb cmdtext+4,#^A/H/ ;alternate form hex? ! bneq 10$ ;br if not ! movb #^A/X/,cmdtext+4 ;force to X !10$: cmpb cmdtext+5,#^A/S/ ;Symbol transfer mode? ! beql 15$ ;br if "S" ! cmpb cmdtext+5,#^A/L/ ;Literal transfer mode? ! beql 15$ ;br if "L" ! error msg15 ;invalid transfer mode !15$: bsbw getword ;skip the command word ! bsbw symbols ;get the DCL symbols ! bsbw offlen !20$: cmpl cmdtext,#^A/GET3/ ! bneq 30$ ;br if not reading ACE ! bsbw get ! $exit_s #ss$_normal ;exit with success ! !30$: cmpl cmdtext,#^A/PUT3/ ! beql 50$ ;br if writing ACE ! error msg3 ;invalid command !50$: bsbw put ! $exit_s #ss$_normal ;exit with success ! ! Main entry command parsing and dispatch ! ROUTINE MEMO_STORAGE : NOVALUE = BEGIN ! ! Read foreign command ! CHECK_STATUS ( LIB$GET_FOREIGN ( MEMO_R_CMDDESC, 0, MEMO_W_CMDLEN ) ); IF ( ( MEMO_W_REMLEN = .MEMO_W_CMDLEN ) EQL 0 ) THEN ERROR ( MSG4 ); IF (.MEMO_T_CMDTEXT [4] EQL %CHAR ('H')) ! Alternate form hex THEN MEMO_T_CMDTEXT [4] = %CHAR ('X'); ! ! Sixth character must be S or L ! SELECTONE .MEMO_T_CMDTEXT [5] OF ! SET [%CHAR ('S'), %CHAR ('L')] : ! Symbol or Literal BEGIN GETWORD(); ! Skip the command word SYMBOLS(); ! Set or Get DCL symbols OFFLEN(); ! Read Offset and Length SELECTONE .(MEMO_T_CMDTEXT)<0, 32, 0> OF ! SET ['GET3'] : GET (); ! Retrieve from ACE value ['PUT3'] : PUT (); ! Store into ACE value [OTHERWISE] : ERROR ( MSG3 ); TES; $EXIT (CODE=SS$_NORMAL); ! Slight flow change END; [OTHERWISE] : ERROR ( MSG15 ); ! invalid transfer mode TES; END; ! CTRL/L goes here !;get offset and length from command line !offlen: bsbw offl ;convert a value ! movl length,offset ;move temp to final ! bsbw offl ;now do length for real ! addl3 offset,length,R0 ;error check ! cmpl R0,#tbytes ! blequ 30$ ;br if length and offset will fit ! error msg8 !30$: rsb ! ! Set up MEMO_L_OFFSET and MEMO_L_LENGTH from the command line ! ROUTINE OFFLEN : NOVALUE = BEGIN OFFL (); ! Convert a length value MEMO_L_OFFSET = .MEMO_L_LENGTH; ! First value is actually the offset OFFL (); ! Convert a length value IF ( .MEMO_L_OFFSET + .MEMO_L_LENGTH ) GTRU MEMO_S_TBYTES THEN ERROR ( MSG8 ); ! %MEMO-F-TOOBIG END; !offl: bsbw getword ;find text ! cmpb @pword,#^A/9/ ;decimal digit? ! blequ 50$ ;br if numeric and convert to bin ! get_symbol lword, insym, inlen ;assume it's a symbol ! cmpl R0,#ss$_normal ;found symbol okay? ! beql 10$ ! error msg1 ;expected symbol !10$: moval intext,pword ;point to the translated text ! movw inlen,lword ;length for conversion !50$: bsbw dig10 ;check that it is a good literal ! pushal length ;setup to get value ! pushl pword ;push address of value text ! cvtwl lword,R0 ! pushl R0 ;push length of word ! calls #3,G^lib$cvt_dtb ;convert to binary ! rsb ! ! Convert a command offset or length to binary ! ROUTINE OFFL : NOVALUE = BEGIN LOCAL STATUS; GETWORD(); ! Read the command word ! ! If the command word starts numeric, fetch a DCL symbol ! IF .(.MEMO_R_WORD [DSC$A_POINTER])<0,08,0> GTRU %CHAR('9') ! THEN BEGIN ! It is a symbol IF GET_SYMBOL ( WORD, INSYM, MEMO_L_INLEN ) NEQ SS$_NORMAL THEN ERROR ( MSG1 ); ! %MEMO-F-OFFSYM MEMO_R_WORD [DSC$A_POINTER] = MEMO_T_INTEXT; MEMO_R_WORD [DSC$W_LENGTH] = .MEMO_L_INLEN; END; ! It is a symbol ! ! Store the binary in MEMO_L_LENGTH ! DIG10 (); ! Ensure it is a good literal LIB$CVT_DTB (.MEMO_R_WORD [DSC$W_LENGTH], .MEMO_R_WORD [DSC$A_POINTER], MEMO_L_LENGTH) END; !dig10: movl pword,R0 ;text in word should be decimal digits ! movl lword,R1 ;setup for check !10$: cmpb (R0),#^A/0/ ;what kind of character? ! blssu nerr ;br if below "0" ! cmpb (R0)+,#^A/9/ ;decimal digit? ! bgtru nerr ;br if above "9" ! sobgtr R1,10$ ! rsb ;success, all characters digits !nerr: error msg9 ;invalid decimal number ! ! Validate a command word as a decimal literal ! ROUTINE DIG10 : NOVALUE = BEGIN INCRA EACH_CHAR FROM .MEMO_R_WORD [DSC$A_POINTER] ! TO .MEMO_R_WORD [DSC$A_POINTER] + .MEMO_R_WORD [DSC$W_LENGTH] - 1 DO IF (.(.EACH_CHAR)<0,08,0> LSS %CHAR('0') ) ! OR (.(.EACH_CHAR)<0,08,0> GTR %CHAR('9') ) ! THEN ERROR ( MSG9 ); ! %MEMO-F-BADCHR END; !getword:clrw lword ;flag for word not found ! tstw remlen ;anything to search? ! bgtr 10$ ;br if over zero ! error msg7 ;operand missing !10$: locc #^A/ /,remlen,@remtext ;scan text for a space ! movl remtext,pword ;point to start of word found ! subw3 r0,remlen,lword ;length of word found ! subw2 lword,remlen ;update remaining text ! decw remlen ;correct for space found ! cvtwl lword,r0 ! addl2 r0,remtext ;update remaining text pointer ! incl remtext ;skip space !30$: rsb ;exit with pword and lword describing word found ! ! Parse a word from the command line ! ROUTINE GETWORD : NOVALUE = BEGIN LOCAL SPACE_LOC; ! ! Set up descriptor MEMO_R_WORD to describe the next word ! MEMO_R_WORD [DSC$W_LENGTH] = 0; IF .MEMO_W_REMLEN LEQ 0 THEN ERROR ( MSG7 ); ! %MEMO-F-NODATA SPACE_LOC = CH$FIND_CH (.MEMO_W_REMLEN, .MEMO_A_REMTEXT, %CHAR(' ')); IF CH$FAIL(.SPACE_LOC) THEN SPACE_LOC = .MEMO_A_REMTEXT + .MEMO_W_REMLEN; MEMO_R_WORD [DSC$A_POINTER] = .MEMO_A_REMTEXT; MEMO_R_WORD [DSC$W_LENGTH] = .SPACE_LOC - .MEMO_A_REMTEXT; ! ! Set up MEMO_W_REMLEN and MEMO_A_REMTEXT to describe what remains ! MEMO_A_REMTEXT = .SPACE_LOC; IF (MEMO_W_REMLEN = .MEMO_W_REMLEN - .MEMO_R_WORD [DSC$W_LENGTH]) NEQ 0 THEN BEGIN ! Skip over the space we found for the remaining ! MEMO_W_REMLEN = .MEMO_W_REMLEN - 1; MEMO_A_REMTEXT = .MEMO_A_REMTEXT + 1; ! END; ! Skip over the space we found for the remaining END; ! CTRL/L goes here !symbols:cmpb cmdtext+3,#^A/5/ ;five argument command? ! beql 50$ ;br if five ! get_symbol name, idtext, idlen ;get the name symbol ! cmpl R0,#ss$_normal ;found symbol okay? ! beql 10$ ;br if found !5$: error msg5 ;something wrong with symbol !10$: cmpl idlen,#8 ;check the length ! bgtru 5$ ;must be 8 bytes or less ! get_symbol filesym,file,file ;get the file name ! cmpl R0,#ss$_normal ;found symbol okay? ! beql 30$ ;br if found ! error msg6 ;not found !30$: rsb ! !50$: movb #^A/3/,cmdtext+3 ;satisfy GET3, PUT3 following ! bsbw getword ;point to the filespec ! movw lword, file ;built descriptor for file ! movl pword,file+4 ! set_symbol filesym, file ;create file symbol ! cmpb R0,#ss$_normal ;created? ! beql 70$ !60$: $exit_s R0 ;failed, return with error !70$: bsbw getword ;point to the ACE name ! cmpw lword,#8 ;error check ! blequ 80$ ;requiring 8 or less ! brw 5$ ;report error !80$: movc5 lword,@pword,#^A/ /,#8,target ;move for ACE get/put ! set_symbol name, idtext ;create name symbol ! cmpb R0,#ss$_normal ;created? ! bneq 60$ ! rsb ! ! Set up or Retrieve DCL symbols indicating Memo file and ACE name ! ROUTINE SYMBOLS : NOVALUE = BEGIN LOCAL STATUS; IF .MEMO_T_CMDTEXT [3] NEQ %CHAR('5') THEN BEGIN ! 3 argument command ! ! Retrieve symbol MEMO_STORAGE_NAME ! IF GET_SYMBOL ( NAME, IDTEXT, MEMO_L_IDLEN ) NEQ SS$_NORMAL THEN ERROR ( MSG5 ); ! %MEMO-F-NAME IF .MEMO_L_IDLEN GTR 8 THEN ERROR ( MSG5 ); ! %MEMO-F-NAME ! ! Retrieve symbol MEMO_STORAGE_FILE ! IF GET_SYMBOL ( FILESYM, FILE, MEMO_R_FILE ) NEQ SS$_NORMAL THEN ERROR ( MSG6 ); ! %MEMO-F-FILE END ! 3 argument command ELSE BEGIN ! 5 argument command MEMO_T_CMDTEXT [3] = %CHAR('3'); ! Fool the upper level parser ! ! Target file name from the command ! GETWORD (); MEMO_R_FILE [DSC$W_LENGTH] = .MEMO_R_WORD [DSC$W_LENGTH]; MEMO_R_FILE [DSC$A_POINTER] = .MEMO_R_WORD [DSC$A_POINTER]; ! ! Save target file name in MEMO_STORAGE_FILE symbol ! IF (STATUS = SET_SYMBOL ( FILESYM, FILE )) NEQ SS$_NORMAL THEN $EXIT (CODE=.STATUS); ! ! ACE name from the command gets stored in MEMO_R_ACEHED ! GETWORD(); IF .MEMO_R_WORD [DSC$W_LENGTH] GTR MEMO_S_TARGET THEN ERROR ( MSG5 ); ! %MEMO-F-NAME CH$COPY (.MEMO_R_WORD [DSC$W_LENGTH], .MEMO_R_WORD [DSC$A_POINTER], %CHAR(' '), MEMO_S_TARGET, MEMO_R_ACEHED [ACE$L_INFO_FLAGS] ); ! ! Save ACE name in MEMO_STORAGE_NAME symbol ! IF (STATUS = SET_SYMBOL ( NAME, IDTEXT )) NEQ SS$_NORMAL THEN $EXIT (CODE=.STATUS); END ! 5 argument command END; ! CTRL/L goes here !put: bsbw getword ;scan for the data string ! cvtwl lword,R0 ;get length of data string ! bneq 5$ ! error msg7 ;data missing !5$: bsbw symchk ;check if transfer via symbol ! bsbw loadace ;load previous ACE or setup to create new ACE ! cmpb cmdtext+4,#^A/A/ ;ascii data to store? ! bneq 10$ ! moval memo,R1 ;address of data buffer ! addl offset,R1 ! movc3 length,@pword,(R1) ;Just move ascii text to ACE data ! cvtlw length,vallst ;setup descriptor ! brb 50$ !10$: cmpb cmdtext+4,#^A/D/ ;decimal data? ! bneq 30$ ! bsbw decimali ! brb 50$ !30$: cmpb cmdtext+4,#^A/X/ ;hex? ! beql 40$ ! brw badtype ;br if not X !40$: bsbw hexbin ;convert hex to binary !50$: bsbw update ;update or create the ACE ! rsb ! ! Store into ACE value from a DCL symbol ! ROUTINE PUT : NOVALUE = BEGIN ! ! Read a word from the command line ! GETWORD (); IF .MEMO_R_WORD [DSC$W_LENGTH] EQL 0 THEN ERROR ( MSG7 ); ! %MEMO-F-NODATA ! ! If the sixth command character is "S", translate a DCL symbol ! SYMCHK (); ! ! Get current ace and set up buffers ! LOADACE (); ! ! Translate appropriate type interpretation and store as binary in ACE ! CASE .MEMO_T_CMDTEXT [4] FROM %CHAR('A') TO %CHAR('X') OF SET [%CHAR('A')] : BEGIN CH$MOVE (.MEMO_L_LENGTH, .MEMO_R_WORD [DSC$A_POINTER], MEMO_R_INBUF [ACE$B_SIZE] + MEMO_S_HEDSIZ + .MEMO_L_OFFSET); MEMO_R_VALLST [DSC$W_LENGTH] = .MEMO_L_LENGTH; END; [%CHAR('D')] : BEGIN DECIMALI (); END; [%CHAR('X')] : BEGIN HEXBIN (); END; [INRANGE,OUTRANGE] : ERROR ( MSG12 ); ! %MEMO-F-BADTYPE TES; ! ! Write ACE to file ! UPDATE (); ! END; !decimali:cmpl length,#1 ;validate length ! beql 40$ ! cmpl length,#2 ;validate length ! beql 40$ ! cmpl length,#4 ;validate length ! beql 40$ ! brw baddec ;length NG !40$: bsbw dig10 ;check that text is decimal digits ! pushal dval ;longword for converted result ! pushal lword ;descriptor of signed integer text ! calls #2,G^ots$cvt_ti_l ;translate ascii to longword ! moval memo,R1 ;address of data buffer ! addl offset,R1 ! movc3 length,dval,(R1) ;move binary bytes to ACE data ! cvtlw length,vallst ;setup descriptor ! rsb !valsym: error msg14 ;no value symbol ! ! Translate Decimal interpretation and store as binary in ACE ! ROUTINE DECIMALI : NOVALUE = BEGIN CASE .MEMO_L_LENGTH FROM 1 TO 4 OF SET [1,2,4] : BEGIN DIG10 (); ! Validate as decimal ! ! Convert to binary ! OTS$CVT_TI_L ( MEMO_R_WORD [DSC$W_LENGTH], MEMO_L_DVAL ); ! ! Copy to ACE buffer ! CH$MOVE (.MEMO_L_LENGTH, MEMO_L_DVAL, MEMO_R_INBUF [ACE$B_SIZE] + MEMO_S_HEDSIZ + .MEMO_L_OFFSET); MEMO_R_VALLST [DSC$W_LENGTH] = .MEMO_L_LENGTH; END; [INRANGE,OUTRANGE] : ERROR ( MSG11 ); ! %MEMO-F-BADDEC TES; END; ! CTRL/L goes here !symchk: cmpb cmdtext+5,#^A/S/ ;symbol data? ! bneq 30$ ;br if data in command line ! get_symbol lword, insym, inlen ;get the equiv text ! cmpl R0,#ss$_normal ;found symbol okay? ! beql 10$ ! brw valsym !10$: moval intext,pword ;point to the translated text ! movw inlen,lword !30$: rsb ! ! If the sixth command character is "S", translate a DCL symbol ! ROUTINE SYMCHK : NOVALUE = BEGIN IF .MEMO_T_CMDTEXT [5] EQL %CHAR('S') THEN BEGIN IF GET_SYMBOL ( WORD, INSYM, MEMO_L_INLEN ) NEQ SS$_NORMAL THEN ERROR ( MSG14 ); ! %MEMO-F-VALSYM MEMO_R_WORD [DSC$A_POINTER] = MEMO_T_INTEXT; MEMO_R_WORD [DSC$W_LENGTH] = .MEMO_L_INLEN; END; END; !loadace:bsbw getace ;get our current ace (if any) ! movw #acl$c_modaclent,cmd ;assume modify ACE with new values ! cmpl R0,#ss$_normal ;did we find it? ! beql 10$ ;br if found ! movw #acl$c_addaclent,cmd ;switch to add ACE with new values ! movc3 #hedsiz,acehed,inbuf ;create new protected header ! rsb !10$: movzbw inbuf,dellst ;Save exact copy of ACE in case ! movc3 dellst,inbuf,delbuf ;we end up deleting this ACE. ! moval memo,R1 ;address of binary data buffer ! addl2 offset,R1 ;point to start of altered area ! movc5 #0,0,#0,length,(R1) ;clear old data ! rsb ! ! Get current ace and set up buffers ! ROUTINE LOADACE : NOVALUE = BEGIN LOCAL STATUS; ! ! Read the ACE ! IF GETACE() NEQU SS$_NORMAL THEN BEGIN ! Did not find the ACE MEMO_R_ITMLST [0,ITM$W_ITMCOD] = ACL$C_ADDACLENT; ! Will add CH$MOVE (MEMO_S_HEDSIZ, MEMO_R_ACEHED, MEMO_R_INBUF); ! create new protected header END ! Did not find the ACE ELSE BEGIN ! Found the ACE MEMO_R_ITMLST [0, ITM$W_ITMCOD] = ACL$C_MODACLENT; ! Will modify ! ! Save exact copy of ACE in case we end up deleting this ACE. ! MEMO_R_DELLST [0,ITM$W_BUFSIZ] = .MEMO_R_INBUF [ACE$B_SIZE]; CH$MOVE (.MEMO_R_DELLST [0,ITM$W_BUFSIZ], MEMO_R_INBUF, MEMO_R_DELBUF); CH$FILL (0, .MEMO_L_LENGTH, MEMO_R_INBUF[ACE$B_SIZE] + MEMO_S_HEDSIZ + .MEMO_L_OFFSET); END; ! Found the ACE END; !update: movl #tbytes,R1 ;buffer size !10$: tstb memo-1[R1] ;find highest address non-zero data byte ! bneq 30$ ;stop at first non-zeor ! sobgtr R1,10$ ;scan backword to first non-zero ! cmpw cmd,#acl$c_modaclent ;no data, does ACE exist? ! bneq 20$ ;br if no existing ACE ! brw 70$ ;br if ACE exists !20$: movl #ss$_normal,R0 ;no ACE, just exit, no data to write ! rsb !30$: addb3 #hedsiz,R1,inbuf ;size of the ACE ! movzbw inbuf,itmlst ;size to item list ! get_symbol prot, protext, protlen ;get the protection status ! cmpl R0,#lib$_nosuchsym ;protection symbol not found? ! beql 50$ ;make no change in status ! bisw2 #ace$m_protected,inbuf+2 ;assume the ACE to be protected ! cmpl protval,#^A/FALS/ ;translates as FALSE? ! bneq 50$ ;br if not FALS ! bicw2 #ace$m_protected,inbuf+2 ;clear the protected bit !50$: $change_acl_s objtyp=#acl$c_file,- ;object type is a file ! objnam=file,- ;file name ! itmlst=itmlst,- ! contxt=contxt ! rsb ! !;Alteration left the ACE empty (all nulls), so delete it. !70$: $change_acl_s objtyp=#acl$c_file,- ;object type is a file ! objnam=file,- ;file name ! itmlst=dellst,- ;delete saved copy of old ACE ! contxt=contxt ! rsb ! ! Store ACE into file (or erase from file) ! ROUTINE UPDATE = BEGIN LOCAL FIRST_NULL : INITIAL (0); ! ! Find the size of the new ACE ! DECR EACH_CHAR FROM MEMO_S_TBYTES-1 TO 0 DO IF .(MEMO_R_INBUF+MEMO_S_HEDSIZ+.EACH_CHAR)<0,8,0> NEQ 0 THEN BEGIN FIRST_NULL = .EACH_CHAR + 1; EXITLOOP; END; IF .FIRST_NULL NEQ 0 THEN BEGIN ! Data is present ! ! We will write an ACE ! MEMO_R_INBUF [ACE$B_SIZE] = MEMO_S_HEDSIZ + .FIRST_NULL; MEMO_R_ITMLST [0, ITM$W_BUFSIZ] = .MEMO_R_INBUF [ACE$B_SIZE]; ! ! Determine whether ACE should be Protected ! IF GET_SYMBOL ( PROT, PROTEXT, MEMO_L_PROTLEN ) NEQ LIB$_NOSUCHSYM THEN BEGIN ! There is a symbol, we will make a change MEMO_R_INBUF [ACE$V_PROTECTED] = 1; ! ! Not clear the corresponding VAX Macro test ever found this text ! IF CH$EQL (.MEMO_L_PROTLEN, .MEMO_R_PROTEXT [DSC$A_POINTER], ! %CHARCOUNT('FALSE'), UPLIT BYTE ('FALSE'), 0) THEN MEMO_R_INBUF [ACE$V_PROTECTED] = 0; END; ! There is a symbol, we will make a change ! ! Write the ACE ! $CHANGE_ACL ( OBJTYP = %REF (ACL$C_FILE), ! OBJNAM = MEMO_R_FILE, ! ITMLST = MEMO_R_ITMLST, ! CONTXT = MEMO_L_CONTXT ) END ! Data is present ELSE BEGIN ! No data ! ! Perhaps there was no previous ACE ! IF .MEMO_R_ITMLST [0, ITM$W_ITMCOD] NEQ ACL$C_MODACLENT THEN RETURN SS$_NORMAL; ! ! Alteration left a previous ACE empty (all nulls), so delete it. ! $CHANGE_ACL ( OBJTYP = %REF (ACL$C_FILE), ! OBJNAM = MEMO_R_FILE, ! ITMLST = MEMO_R_DELLST, ! CONTXT = MEMO_L_CONTXT ) END ! No data END; ! CTRL/L goes here !;convert hexadecimal string to binary bytes, overlaying old ACE !hexbin: movl pword,R6 ;point to hex field ! movl lword,R9 ;get size of hex field ! blbc R9,10$ ;br if an even number ! decl R6 ;point to previous byte ! movb #^A/0/,(R6) ;force to "0" ! incl R9 ;round size to even number !10$: cmpb lr,#^A/R/ ;convert right to left? ! bneq 35$ ;br if left to right ! addl R9,R6 ;point to end of hex area !35$: ashl #-1,R9,R9 ;divide by 2 for number of bytes ! movl R9,R8 ;loop counter for below ! moval memo,R7 ;binary data pointer ! addl offset,R7 ;include the offset !40$: movzbl -(R6),R9 ;get a hex digit ! bsbw binit ;convert to binary ! movzbl R9,R1 ;save low four bits ! movzbl -(R6),R9 ;get next higher hex digit ! bsbw binit ;convert to binary ! ashl #4,R9,R9 ;shift to high nibble position ! bisb3 R1,R9,(R7)+ ;store in binary byte ! sobgtr R8,40$ ! rsb ! ! Translate Hexadecimal interpretation and store as binary in ACE ! ROUTINE HEXBIN : NOVALUE = BEGIN LOCAL OUTPUT_POINTER, COUNTER, SOURCE_POINTER; SOURCE_POINTER = .MEMO_R_WORD [DSC$A_POINTER]; COUNTER = .MEMO_R_WORD [DSC$W_LENGTH]; ! ! Odd byte counts result in a spare nibble ! IF .COUNTER THEN BEGIN ! It was an odd number SOURCE_POINTER = .SOURCE_POINTER-1; .SOURCE_POINTER<0,08,0> = %CHAR('0'); COUNTER = .COUNTER + 1; END; ! It was an odd number IF .MEMO_B_LR EQL %CHAR('R') THEN SOURCE_POINTER = .SOURCE_POINTER + .COUNTER; ! ! Output binary is half the length of input ASCII ! COUNTER = .COUNTER/2; ! Loop counter ! ! Convert each source byte ! OUTPUT_POINTER = MEMO_R_INBUF [ACE$B_SIZE] + MEMO_S_HEDSIZ + .MEMO_L_OFFSET; DO BEGIN SOURCE_POINTER = .SOURCE_POINTER-1; (.OUTPUT_POINTER)<0,04,0> = BINIT (.(.SOURCE_POINTER)<0,08,0>); SOURCE_POINTER = .SOURCE_POINTER-1; (.OUTPUT_POINTER)<4,04,0> = BINIT (.(.SOURCE_POINTER)<0,08,0>); OUTPUT_POINTER = .OUTPUT_POINTER + 1; END UNTIL ( COUNTER = .COUNTER - 1 ) LEQ 0; END; !binit: cmpb R9,#^A/9/ ;result greater than nine? ! blequ 10$ ;br if 0-9 range ! cmpb R9,#^A/A/ ;make sure in A-F range ! blssu 30$ ;br if between 9 and A ! cmpb R9,#^A/F/ ;make sure in A-F range ! bgtru 30$ ;br if past F ! subb2 #^A/A/-^A/:/,R9 ;correct A-F range ! bicb2 #^XF0,R9 ;strip to four bits ! rsb !10$: cmpb R9,#^A/0/ ;make sure it's in 0-9 range ! blssu 30$ ;br if below 0 character ! bicb2 #^XF0,R9 ;strip to four bits ! rsb !30$: error msg2 ;invalid hex char ! ! Convert a single ASCII byte to Hexadecimal ! ROUTINE BINIT ( IN_CHAR ) = BEGIN CASE .IN_CHAR FROM %CHAR('0') TO %CHAR('F') OF SET ['0','1','2','3','4','5','6','7','8','9'] : .IN_CHAR AND %X'F'; ['A','B','C','D','E','F'] : (.IN_CHAR-%CHAR('A')+%CHAR(':')) AND %X'F'; [INRANGE,OUTRANGE] : ( ERROR ( MSG2 );0); ! %MEMO-F-NOTHEX TES END; !;branch/jump here with error text message descriptor address pushed on stack. !errormsg:calls #1,G^lib$put_output ;output error text message ! $exit_s #16 ;exit with bad parameter ROUTINE ERRORMSG ( ERROR_DESC : REF $BBLOCK [8] ) : NOVALUE = BEGIN LIB$PUT_OUTPUT (ERROR_DESC[DSC$W_LENGTH]); $EXIT (CODE=SS$_BADPARAM AND STS$M_COND_ID); ! Only a warning END; ! CTRL/L goes here !get: cmpb cmdtext+5,#^A/S/ ;symbol transfer mode? ! beql 5$ ;br if output to symbol ! error msg13 ;require symbol !5$: bsbw getace ;get our ace ! cmpb cmdtext+4,#^A/A/ ;ascii output? ! bneq 10$ ;br if not ! bsbw asciio ! brb 50$ !10$: cmpb cmdtext+4,#^A/D/ ;decimal output? ! bneq 20$ ;br if not ! bsbw decimalo ! brb 50$ !20$: cmpb cmdtext+4,#^A/X/ ;hex? ! bneq badtype ;br if not X here ! cmpl length,#128 ;will it fit in symbol? ! blss 30$ ;br if less than 128 ! error msg10 !30$: bsbw hexer ;convert data to hex !50$: bsbw getword ;find the data symbol ! set_symbol lword, vallst ;create the returned value symbol ! cmpb R0,#ss$_normal ;created? ! beql 70$ ! $exit_s R0 ;failed, return with error !70$: rsb ! !badtype:error msg12 ! ! Retrieve ACE value into a DCL symbol ! ROUTINE GET : NOVALUE = BEGIN LOCAL STATUS; IF .MEMO_T_CMDTEXT [5] NEQ %CHAR('S') THEN ERROR ( MSG13 ); ! %MEMO-F-BADMODE GETACE (); ! ! Fill word buffer with appropriate interpretation of ACE contents ! CASE .MEMO_T_CMDTEXT [4] FROM %CHAR('A') TO %CHAR('X') OF SET ['A'] : ASCIIO (); ['D'] : DECIMALO (); ['X'] : BEGIN IF .MEMO_L_LENGTH GEQ 128 THEN ERROR ( MSG10 ); ! %MEMO-F-BIGSYM HEXER (); END; [INRANGE,OUTRANGE] : ERROR ( MSG12 ); ! %MEMO-F-BADTYPE TES; GETWORD (); IF (STATUS = SET_SYMBOL (WORD, VALLST)) NEQ SS$_NORMAL THEN $EXIT (CODE=.STATUS); .STATUS END; !asciio: moval memo,R1 ;address of data buffer ! addl offset,R1 ! movc3 length,(R1),hexvals ;Just move ascii text to symbol ! cvtlw length,vallst ;setup descriptor ! rsb ! ! Fill Hexvals buffer with Ascii interpretation of ACE contents ! ROUTINE ASCIIO : NOVALUE = BEGIN CH$MOVE (.MEMO_L_LENGTH, MEMO_R_INBUF [ACE$B_SIZE] + MEMO_S_HEDSIZ + .MEMO_L_OFFSET, MEMO_T_HEXVALS [0]); MEMO_R_VALLST [DSC$W_LENGTH] = .MEMO_L_LENGTH; END; ! CTRL/L goes here !hexer: movl length,R8 ! ashl #1,R8,R0 ;2x #bytes in R0 = #hex digits ! movw R0,vallst ;length of string ! moval hexvals,R6 ;point to hex buffer ! cmpb lr,#^A/R/ ;convert right to left? ! bneq 30$ ;br if left to right ! addl R0,R6 ;point to end of hex data !30$: moval memo,R7 ;binary data buffer ! addl offset,R7 ;add in amount of offset !40$: movb (R7),R0 ;get a byte ! bsbw hexit ;store low hex digit in buffer ! movb (R7)+,R0 ;now do the high digit ! ashl #-4,R0,R0 ;shift left ! bsbw hexit ;store high hex digit in buffer ! sobgtr R8,40$ ! rsb ! ! Fill Hexvals buffer with Hexadecimal interpretation of ACE contents ! ROUTINE HEXER : NOVALUE = BEGIN LOCAL OUTPUT_POINTER, INPUT_POINTER, COUNT; COUNT = .MEMO_L_LENGTH; MEMO_R_VALLST [DSC$W_LENGTH] = .COUNT*2; OUTPUT_POINTER = MEMO_T_HEXVALS; IF .MEMO_B_LR EQL %CHAR('R') THEN OUTPUT_POINTER = .OUTPUT_POINTER+.MEMO_R_VALLST [DSC$W_LENGTH]; INPUT_POINTER = MEMO_R_INBUF [ACE$B_SIZE] + MEMO_S_HEDSIZ + .MEMO_L_OFFSET; DO BEGIN HEXIT (.(.INPUT_POINTER)<0,04,0>, OUTPUT_POINTER); HEXIT (.(.INPUT_POINTER)<4,04,0>, OUTPUT_POINTER); INPUT_POINTER = .INPUT_POINTER + 1; END WHILE (COUNT=.COUNT-1) GTR 0; END; !hexit: bicb2 #^XF0,R0 ;get low four bits ! addb2 #^A/0/,R0 ;convert to ascii digit ! cmpb R0,#^A/9/ ;digit over nine? ! bleq 10$ ;br if not ! addb2 #^A/A/-^A/:/,R0 ;convert to A-F range !10$: cmpb lr,#^A/R/ ;convert right to left? ! bneq 15$ ;br if left to right ! movb R0,-(R6) ;store in hex buffer ! rsb !15$: movb R0,(R6)+ ;store in hex buffer ! rsb ! ! Convert a single ACE nibble to hexadecimal and store in buffer ! ROUTINE HEXIT ( NIBBLE, POINTER : REF VECTOR ) : NOVALUE = BEGIN LOCAL MY_NIBBLE : INITIAL ( .NIBBLE AND %X'F' ); CASE .MY_NIBBLE FROM 0 TO %X'F' OF SET [0 TO 9] : MY_NIBBLE = .MY_NIBBLE + %CHAR('0'); [%X'A' TO %X'F'] : MY_NIBBLE = .MY_NIBBLE - %X'A' + %CHAR('A'); [INRANGE,OUTRANGE] :; TES; IF .MEMO_B_LR EQL %CHAR('R') THEN BEGIN POINTER [0] = .POINTER [0] - 1; (.POINTER [0])<0,08,0> = .MY_NIBBLE; END ELSE BEGIN (.POINTER [0])<0,08,0> = .MY_NIBBLE; POINTER [0] = .POINTER [0] + 1; END; END; ! CTRL/L goes here !decimalo:moval memo,R6 ;address of data buffer ! addl2 offset,R6 ;address of data ! clrl R2 ;assume positive for 1 and 2 ! cmpl length,#4 ! beql 40$ ;br if 4 bytes ! cmpl length,#2 ! beql 20$ ;br if 2 bytes ! cmpl length,#1 ! bneq baddec ;br if not 1 byte !10$: tstb (R6) ;test sign of byte ! bgtr 12$ ;br if positive ! decl R2 ;-1 !12$: movc5 #0,0,R2,#3,1(R6) ;fill three high bytes ! brb 40$ !20$: tstw (R6) ;test sign of word ! bgtr 22$ ;br if positive ! decl R2 ;-1 !22$: movw R2,2(R6) ;fill two high bytes !40$: pushal dtext ;address of ascii translation ! pushl R6 ! calls #2,G^ots$cvt_l_ti ;convert long to ascii, signed ! skpc #^A/ /,dtext,dtext+8 ;find first non-space ! cvtlw R0,vallst ;setup descriptor ! movc3 R0,(R1),hexvals ;move ascii text to symbol ! rsb ! !baddec: error msg11 ;invalid length ! ! Fill Hexvals buffer with Decimal interpretation of ACE contents ! ROUTINE DECIMALO : NOVALUE = BEGIN LOCAL VALUE_POINTER, FIRST_NON_SPACE; VALUE_POINTER = MEMO_R_INBUF [ACE$B_SIZE] + MEMO_S_HEDSIZ + .MEMO_L_OFFSET; CASE .MEMO_L_LENGTH FROM 1 TO 4 OF SET [1] : .VALUE_POINTER = .(.VALUE_POINTER)<0,08,1>; [2] : .VALUE_POINTER = .(.VALUE_POINTER)<0,16,1>; [4] :; [INRANGE,OUTRANGE] : ERROR ( MSG11 ); ! %MEMO-F-BADDEC TES; OTS$CVT_L_TI ( .VALUE_POINTER, MEMO_R_DTEXT ); FIRST_NON_SPACE = CH$FIND_NOT_CH (.MEMO_R_DTEXT [DSC$W_LENGTH],.MEMO_R_DTEXT[DSC$A_POINTER],%CHAR(' ')); IF CH$FAIL(FIRST_NON_SPACE) THEN FIRST_NON_SPACE = ! .MEMO_R_DTEXT [DSC$W_LENGTH]+.MEMO_R_DTEXT[DSC$A_POINTER]; MEMO_R_VALLST [DSC$W_LENGTH] = ! MEMO_T_DTEXT + .MEMO_R_DTEXT [DSC$W_LENGTH] - .FIRST_NON_SPACE; CH$COPY ( .MEMO_R_VALLST [DSC$W_LENGTH], .FIRST_NON_SPACE, %CHAR (' '), .MEMO_R_VALLST [DSC$W_LENGTH], MEMO_T_HEXVALS ); END; !getace: movw #acl$c_readace,cmd ;read an ace from the acl ! clrl contxt ;starting with the first ! movw #bufsiz,itmlst ;set the input buffer size !10$: $change_acl_s objtyp=#acl$c_file,- ;object type is a file ! objnam=file,- ;file name ! itmlst=itmlst,- ! contxt=contxt ! movl R0,R8 ;save for later ! cmpl #ss$_normal,R0 ! bneq 20$ ;br if not target ace ! cmpc3 #8,target,acename ;found our ace? ! bneq 10$ ;br if not and try next !20$: movl R8,R0 ;restore status ! cmpl #ss$_normal,R0 ! beql 40$ ! cmpl #ss$_aclempty,R0 ! beql 30$ ! cmpl #ss$_nomoreace,R0 ! beql 30$ ! bsbw check_status ;report strange errors and quit !30$: pushl R0 ! movc5 #0,0,#0,#tbytes,memo ;clear any garbage loaded by V5.3 ! popl R0 !40$: rsb ! ! Retrieve ACE named in ACEHED from file name in FILE ! ROUTINE GETACE = BEGIN LOCAL STATUS; MEMO_R_ITMLST [0,ITM$W_ITMCOD] = ACL$C_READACE; MEMO_L_CONTXT = 0; MEMO_R_ITMLST [0, ITM$W_BUFSIZ] = MEMO_S_BUFSIZ; DO BEGIN ! Get another ACE STATUS = $CHANGE_ACL ( OBJTYP = %REF (ACL$C_FILE), ! OBJNAM = MEMO_R_FILE, ! ITMLST = MEMO_R_ITMLST, ! CONTXT = MEMO_L_CONTXT ); IF .STATUS NEQ SS$_NORMAL THEN BEGIN ! Not normal status IF (.STATUS NEQ SS$_ACLEMPTY) AND (.STATUS NEQ SS$_NOMOREACE) THEN CHECK_STATUS (.STATUS); CH$COPY (0,0,0,MEMO_S_TBYTES,MEMO_R_INBUF[ACE$B_SIZE]+MEMO_S_HEDSIZ); RETURN .STATUS; END; ! Not normal status END ! Get another ACE UNTIL (.STATUS AND CH$EQL (MEMO_S_TARGET,MEMO_R_ACEHED [ACE$L_INFO_FLAGS], MEMO_S_TARGET,MEMO_R_INBUF [ACE$L_INFO_FLAGS], %CHAR(' '))); RETURN .STATUS; END; END ELUDOM Top of Page