Relay-Version: version nyu B notes v1.6.1 1/11/90; site acf3.NYU.EDU
From: ISIS08@ECOSTAT.AAU.DK
Date: 31 Dec 90 14:06 EST
Date-Received: 31 Dec 90 17:53 EST
Subject: PASCAL + FORTRAN + humor = ?
Message-ID: <DF9C8F934D7F2100F3@vms2.uni-c.dk>
Path: acf3!cmcl2!cmcl2!rutgers!att!tut.cis.ohio-state.edu!ucbvax!ECOSTAT.AAU.DK!ISIS08
Newsgroups: comp.os.vms
Organization: The Internet
Sender: daemon@ucbvax.BERKELEY.EDU
Lines: 155


People with VAX PASCAL, VAX FORTRAN and sense of humor can unshare
the following VMS_SHARE file and make a @DEMO.

                                                           Arne

Arne Vajhxj                             Internet: ISIS08@ECOSTAT.AAU.DK
Institute of Economics and Statistics   PSI:      DATAPAX.23830211371400::ISIS08
Aarhus University
Denmark

--------------------------------------------------------------------------------

$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 7.2-007  22-FEB-1990
$!   On 31-DEC-1990 19:55:26.11   By user ISIS08 
$!
$! This VMS_SHARE Written by:
$!    Andy Harper, Kings College London UK
$!
$! Acknowledgements to:
$!    James Gray       - Original VMS_SHARE
$!    Michael Bednarek - Original Concept and implementation
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. MIRROR.FOR;1
$!       2. MIRROR.INC;1
$!       3. TEST.PAS;1
$!       4. DEMO.COM;1
$!
$set="set"
$set symbol/scope=(nolocal,noglobal)
$f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
$e="write sys$error  ""%UNPACK"", "
$w="write sys$output ""%UNPACK"", "
$ if f$trnlnm("SHARE_LOG") then $ w = "!"
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$UNPACK: SUBROUTINE ! P1=filename, P2=checksum
$ if f$search(P1) .eqs. "" then $ goto file_absent
$ e "-W-EXISTS, File ''P1' exists. Skipped."
$ delete 'f'*
$ exit
$file_absent:
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'."
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
$ delete 'f'*
$ exit
$dirok:
$ w "-I-PROCESS, Processing file ''P1'."
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
"output_file"));ENDPROCEDURE;Unpacker;QUIT;
$ delete/nolog 'f'*
$ CHECKSUM 'P1'
$ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
$ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ ENDSUBROUTINE
$START:
$ create 'f'
X      SUBROUTINE PAS$FV_OUTPUT
X      RETURN
X      END
XC
X      SUBROUTINE PAS$WRITE_INTEGER(U,V,W)
X      INTEGER*4 U,V,W
X      INCLUDE 'MIRROR.INC'
X      WRITE(K(N+1:N+%LOC(W)),'(I<%LOC(W)>)') %LOC(V)
X      N=N+%LOC(W)
X      RETURN
X      END
XC
X      SUBROUTINE PAS$WRITE_STRING(U,NB,STR)
X      INTEGER*4 U,NB
X      BYTE STR(*)
X      INCLUDE 'MIRROR.INC'
X      INTEGER*4 I
X      DO 100 I=N+1,N+%LOC(NB)
X        B(I)=STR(I-N)
X100   CONTINUE
X      N=N+%LOC(NB)
X      RETURN
X      END
XC
X      SUBROUTINE PAS$WRITELN2(U)
X      INTEGER*4 U
X      INCLUDE 'MIRROR.INC'
X      INTEGER*4 I
X      LOGICAL*4 INIT
X      DATA INIT/.TRUE./
X      IF(INIT) THEN
X        OPEN(UNIT=6,FILE='SYS$OUTPUT',STATUS='NEW',
X     +       CARRIAGECONTROL='LIST')
X        INIT=.FALSE.
X      ENDIF
X      DO 100 I=N+1,80
X        B(I)=32
X100   CONTINUE
X      WRITE(6,'(132A1)') (B(I),I=80,1,-1)
X      N=0
X      RETURN
X      END
$ CALL UNPACK MIRROR.FOR;1 477037480
$ create 'f'
X      INTEGER*4 N
X      BYTE B(132)
X      CHARACTER*132 K
X      EQUIVALENCE (B,K)
X      COMMON /MIRROR/N,B
$ CALL UNPACK MIRROR.INC;1 1786669612
$ create 'f'
Xprogram zzzz(input,output);
X
Xbegin
X   write('This is a test - ');
X   writeln(123);
X   writeln('OK ?');
Xend.
$ CALL UNPACK TEST.PAS;1 1649542269
$ create 'f'
X$ set verify
X$ fortran mirror
X$ pascal test
X$ link test
X$ run test
X$ link test+mirror
X$ run test
X$ set noverify
$ CALL UNPACK DEMO.COM;1 677916255
$ v=f$verify(v)
$ EXIT