diff --git a/lispusers/BITMAPFNS.LCOM b/lispusers/BITMAPFNS.LCOM index 78c2d74f9..9d09d57e3 100644 Binary files a/lispusers/BITMAPFNS.LCOM and b/lispusers/BITMAPFNS.LCOM differ diff --git a/lispusers/READAIS b/lispusers/READAIS index 240236111..0e0189d38 100644 --- a/lispusers/READAIS +++ b/lispusers/READAIS @@ -1,23 +1,40 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "28-Apr-88 17:04:57" {ERINYES}MEDLEY>READAIS.;1 48154 - changes to%: (FNS AISBLT AISBLT1TO1 24BITCOLORTO8BITMAP AISBLT8TO4MODUL AISBLT8TOLESSFSA AISBLT8TO4TRUNC AISBLT8TO8 AISBLT4TO4 AISBLT8TO4LESSFSA AISBLT8TO1FSA AISBLT8TO1TRUNC CLOSEST.COLOR GRAPHAISHISTOGRAM AISHISTOGRAM SMOOTHEDFILTER SLOW.COLOR.DISTANCE FAST.COLOR.DISTANCE INSUREAISFILE SHOWCOLORAIS SHOWCOLORAIS1 WRITEAIS WRITEAIS1 \GETBASENYBBLE \PUTBASENYBBLE) - (VARS READAISCOMS) +(FILECREATED "24-Sep-2023 14:35:09" {WMEDLEY}READAIS.;2 63146 - previous date%: "27-Apr-88 12:12:58" {QV}LISP>MEDLEY>READAIS.;2) + :EDIT-BY rmk + :CHANGES-TO (FNS AISHISTOGRAM) -(* " -Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. + :PREVIOUS-DATE "28-Apr-88 17:04:57" {WMEDLEY}READAIS.;1) + + +(* ; " +Copyright (c) 1982-1988 by Xerox Corporation. ") (PRETTYCOMPRINT READAISCOMS) -(RPAQQ READAISCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NYBBLESPERWORD 4))) (* ;; "fixed INSUREAISFILE, AISBLT, AISBLT8TO8. nhb 27-Apr-88 01:58:56") (FNS 24BITCOLORTO8BITMAP AISBLT AISBLT1TO1 AISBLT8TO4MODUL AISBLT8TOLESSFSA AISBLT8TO4TRUNC AISBLT8TO8 AISBLT4TO4 AISBLT8TO4LESSFSA AISBLT8TO1FSA AISBLT8TO1TRUNC CLOSEST.COLOR GRAPHAISHISTOGRAM AISHISTOGRAM SMOOTHEDFILTER SLOW.COLOR.DISTANCE FAST.COLOR.DISTANCE INSUREAISFILE SHOWCOLORAIS SHOWCOLORAIS1 WRITEAIS WRITEAIS1 \GETBASENYBBLE \PUTBASENYBBLE) (MACROS .GET.4BIT.AND.SPREAD.ERR. .GET.1BIT.AND.SPREAD.ERR. .GET.NBIT.AND.SPREAD.ERR. .GET.LEFTMOST.4BIT .GET.LEFTMOST.BIT. .GET.BESTCOLOR.AND.SPREAD.ERR. .4BIT.MODULATE.INTENSITY.VALUE. .MODULATE.INTENSITY.VALUE. SQUARE) (P (MOVD? (QUOTE FAST.COLOR.DISTANCE) (QUOTE COLOR.DISTANCE))) (VARS AISDIRECTORIES) (GLOBALVARS AISDIRECTORIES))) +(RPAQQ READAISCOMS + ((DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NYBBLESPERWORD 4))) + + (* ;; "fixed INSUREAISFILE, AISBLT, AISBLT8TO8. nhb 27-Apr-88 01:58:56") + + (FNS 24BITCOLORTO8BITMAP AISBLT AISBLT1TO1 AISBLT8TO4MODUL AISBLT8TOLESSFSA AISBLT8TO4TRUNC + AISBLT8TO8 AISBLT4TO4 AISBLT8TO4LESSFSA AISBLT8TO1FSA AISBLT8TO1TRUNC CLOSEST.COLOR + GRAPHAISHISTOGRAM AISHISTOGRAM SMOOTHEDFILTER SLOW.COLOR.DISTANCE FAST.COLOR.DISTANCE + INSUREAISFILE SHOWCOLORAIS SHOWCOLORAIS1 WRITEAIS WRITEAIS1 \GETBASENYBBLE + \PUTBASENYBBLE) + (MACROS .GET.4BIT.AND.SPREAD.ERR. .GET.1BIT.AND.SPREAD.ERR. .GET.NBIT.AND.SPREAD.ERR. + .GET.LEFTMOST.4BIT .GET.LEFTMOST.BIT. .GET.BESTCOLOR.AND.SPREAD.ERR. + .4BIT.MODULATE.INTENSITY.VALUE. .MODULATE.INTENSITY.VALUE. SQUARE) + (P (MOVD? 'FAST.COLOR.DISTANCE 'COLOR.DISTANCE)) + (VARS AISDIRECTORIES) + (GLOBALVARS AISDIRECTORIES))) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE -(RPAQQ NYBBLESPERWORD 4) +(RPAQQ NYBBLESPERWORD 4) (CONSTANTS (NYBBLESPERWORD 4)) @@ -83,8 +100,59 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. Al ) (AISHISTOGRAM -(LAMBDA (FILE REGION) (* kbr%: "13-Jul-85 19:28") (* returns an array that have the number of pixels in FILE that have each intensity.) (PROG (STREAM DATABEG AISHISTOGRAM TMP BITSPERSAMPLE SFILEWIDTH SFILEHEIGHT SFILEBYTESPERLINE LEFT BOTTOM RIGHT TOP WIDTH HEIGHT BEG END) (COND ((OR (SETQ STREAM (FINDFILE FILE NIL AISDIRECTORIES)) (SETQ STREAM FILE)) (SETQ STREAM (GETSTREAM (OPENFILE STREAM (QUOTE INPUT)) (QUOTE INPUT))))) (SETQ TMP (INSUREAISFILE STREAM)) (SETQ BITSPERSAMPLE (CAR TMP)) (SETQ SFILEWIDTH (CADR TMP)) (SETQ SFILEHEIGHT (CADDR TMP)) (SETQ SFILEBYTESPERLINE (LLSH (CADDDR TMP) 1)) (SETQ DATABEG (GETFILEPTR STREAM)) (SETQ AISHISTOGRAM (ARRAY (EXPT 2 BITSPERSAMPLE) NIL 0 0)) (COND (REGION (SETQ LEFT (IMAX (IMIN (fetch (REGION LEFT) of REGION) (SUB1 SFILEWIDTH)) 0)) (SETQ RIGHT (IMAX (IMIN SFILEWIDTH (fetch (REGION PRIGHT) of REGION)) 0)) (COND ((IGEQ LEFT RIGHT) (RETURN AISHISTOGRAM)) (T (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)))) (SETQ BOTTOM (IMIN (fetch (REGION BOTTOM) of REGION) (SUB1 SFILEHEIGHT))) (SETQ TOP (IMIN SFILEHEIGHT (fetch (REGION PTOP) of REGION))) (COND ((IGREATERP BOTTOM TOP) (RETURN AISHISTOGRAM))) (SETQ BEG (IPLUS DATABEG (IPLUS (ITIMES SFILEBYTESPERLINE (IDIFFERENCE SFILEHEIGHT TOP)) LEFT))) (SETQ END (IPLUS DATABEG (IPLUS (ITIMES SFILEBYTESPERLINE (IDIFFERENCE SFILEHEIGHT BOTTOM)) LEFT))) (for LINE from BEG to END by SFILEBYTESPERLINE do (\SETFILEPTR STREAM LINE) (for BIT from 1 to WIDTH do (SETA AISHISTOGRAM (SETQ TMP (\BIN STREAM)) (ADD1 (ELT AISHISTOGRAM TMP)))))) (T (for LINE from 1 to SFILEHEIGHT do (for BIT from 1 to SFILEBYTESPERLINE do (SETA AISHISTOGRAM (SETQ TMP (\BIN STREAM)) (ADD1 (ELT AISHISTOGRAM TMP))))))) (CLOSEF STREAM) (RETURN AISHISTOGRAM))) -) + [LAMBDA (FILE REGION) (* ; "Edited 24-Sep-2023 14:34 by rmk") + (* kbr%: "13-Jul-85 19:28") + (* ; + "returns an array that have the number of pixels in FILE that have each intensity.") + (PROG (STREAM DATABEG AISHISTOGRAM TMP BITSPERSAMPLE SFILEWIDTH SFILEHEIGHT SFILEBYTESPERLINE + LEFT BOTTOM RIGHT TOP WIDTH HEIGHT BEG END) + [COND + ((OR (SETQ STREAM (FINDFILE FILE NIL AISDIRECTORIES)) + (SETQ STREAM FILE)) + (SETQ STREAM (OPENSTREAM STREAM 'INPUT] + (SETQ TMP (INSUREAISFILE STREAM)) + (SETQ BITSPERSAMPLE (CAR TMP)) + (SETQ SFILEWIDTH (CADR TMP)) + (SETQ SFILEHEIGHT (CADDR TMP)) + (SETQ SFILEBYTESPERLINE (LLSH (CADDDR TMP) + 1)) + (SETQ DATABEG (GETFILEPTR STREAM)) + (SETQ AISHISTOGRAM (ARRAY (EXPT 2 BITSPERSAMPLE) + NIL 0 0)) + [COND + [REGION (SETQ LEFT (IMAX (IMIN (fetch (REGION LEFT) of REGION) + (SUB1 SFILEWIDTH)) + 0)) + (SETQ RIGHT (IMAX (IMIN SFILEWIDTH (fetch (REGION PRIGHT) of REGION)) + 0)) + [COND + ((IGEQ LEFT RIGHT) + (RETURN AISHISTOGRAM)) + (T (SETQ WIDTH (IDIFFERENCE RIGHT LEFT] + (SETQ BOTTOM (IMIN (fetch (REGION BOTTOM) of REGION) + (SUB1 SFILEHEIGHT))) + (SETQ TOP (IMIN SFILEHEIGHT (fetch (REGION PTOP) of REGION))) + (COND + ((IGREATERP BOTTOM TOP) + (RETURN AISHISTOGRAM))) + (SETQ BEG (IPLUS DATABEG (IPLUS (ITIMES SFILEBYTESPERLINE (IDIFFERENCE + SFILEHEIGHT TOP) + ) + LEFT))) + (SETQ END (IPLUS DATABEG (IPLUS (ITIMES SFILEBYTESPERLINE (IDIFFERENCE + SFILEHEIGHT + BOTTOM)) + LEFT))) + (for LINE from BEG to END by SFILEBYTESPERLINE + do (\SETFILEPTR STREAM LINE) + (for BIT from 1 to WIDTH do (SETA AISHISTOGRAM (SETQ TMP (\BIN STREAM)) + (ADD1 (ELT AISHISTOGRAM TMP] + (T (for LINE from 1 to SFILEHEIGHT + do (for BIT from 1 to SFILEBYTESPERLINE + do (SETA AISHISTOGRAM (SETQ TMP (\BIN STREAM)) + (ADD1 (ELT AISHISTOGRAM TMP] + (CLOSEF STREAM) + (RETURN AISHISTOGRAM]) (SMOOTHEDFILTER (LAMBDA (HISTOGRAM) (* kbr%: "13-Jul-85 15:05") (* returns a 256 to 256 mapping array that maximally distributes the intensity values by looking at the histogram array HISTOGRAM) (PROG (ARSIZE SMOOTHARRAY TOTALPOINTS POINTSLESS FILEINTENSITY NEWINTENSITY POINTSPAST BUCKETSIZE NTOMOVE NPTS) (SETQ ARSIZE (ARRAYSIZE HISTOGRAM)) (SETQ POINTSLESS 0) (SETQ NEWINTENSITY 0) (SETQ POINTSPAST 0) (SETQ SMOOTHARRAY (ARRAY ARSIZE NIL 0 0)) (SETQ TOTALPOINTS (for I from 0 to (SUB1 ARSIZE) sum (ELT HISTOGRAM I))) (SETQ BUCKETSIZE (IQUOTIENT TOTALPOINTS 256)) (for I from 0 to (SUB1 ARSIZE) do (SETQ NPTS (ELT HISTOGRAM I)) (SETQ POINTSLESS (IPLUS POINTSLESS NPTS)) (COND ((IGREATERP POINTSLESS BUCKETSIZE) (SETQ NTOMOVE (IQUOTIENT POINTSLESS BUCKETSIZE)) (SETA SMOOTHARRAY I (IPLUS NEWINTENSITY (IQUOTIENT NTOMOVE 2))) (SETQ NEWINTENSITY (COND ((IGREATERP NEWINTENSITY 255) 255) (T (IPLUS NEWINTENSITY NTOMOVE)))) (SETQ POINTSLESS (IDIFFERENCE POINTSLESS (ITIMES NTOMOVE BUCKETSIZE)))) (T (SETA SMOOTHARRAY I NEWINTENSITY)))) (RETURN SMOOTHARRAY))) @@ -128,41 +196,308 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. Al ) (DECLARE%: EVAL@COMPILE -(PUTPROPS .GET.4BIT.AND.SPREAD.ERR. MACRO ((STREAM) (PROGN (* returns the 4 most significant bits taking into account the error and spreads the error into the appropriate places.) (SETQ BYTE (IPLUS (\BIN STREAM) THISPIXELERROR)) (PROG1 (COND ((IGREATERP BYTE 255) (* overflow case) 15) (T (LRSH BYTE 4))) (SETQ ERR (LOGAND BYTE 15)) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELERROR (IPLUS (\GETBASE ERRTABLEPTR 1) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASE ERRTABLEPTR 1 (LRSH ERR 1)) (* |3/8| to one below) (\PUTBASE ERRTABLEPTR 0 (IPLUS (\GETBASE ERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1)))) (SETQ ERRTABLEPTR (\ADDBASE ERRTABLEPTR 1)))))) - -(PUTPROPS .GET.1BIT.AND.SPREAD.ERR. MACRO ((STREAM) (PROGN (* returns the most significant bit taking into account the error and spreads the error into the appropriate places.) (SETQ BYTE (IPLUS (\BIN STREAM) THISPIXELERROR)) (PROG1 (SETQ VAL (COND ((IGREATERP BYTE 255) (* overflow case) 0) ((IGREATERP 0 BYTE) (* overflow case) 1) (T (LOGXOR (LRSH BYTE 7) 1)))) (SETQ ERR (IDIFFERENCE BYTE (\GETBASE INTENSITYBASE VAL))) (* put |3/8| of error into next pixel, |3/8| to one below and |1/4| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) 2) 64)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THREEEIGHTSERR (IPLUS ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) 1) 128))) (SETQ THISPIXELERROR (IPLUS (\GETBASEPTR ERRTABLEPTR 2) THREEEIGHTSERR)) (* |1/4| of error to next one down to right.) (\PUTBASEPTR ERRTABLEPTR 2 ERR) (* |3/8| to one below) (\PUTBASEPTR ERRTABLEPTR 0 (IPLUS (\GETBASEPTR ERRTABLEPTR 0) THREEEIGHTSERR)) (SETQ ERRTABLEPTR (\ADDBASE ERRTABLEPTR 2)))))) - -(PUTPROPS .GET.NBIT.AND.SPREAD.ERR. MACRO ((STREAM) (PROGN (* returns the NBITS most significant bits taking into account the error and spreads the error into the appropriate places.) (SETQ BYTE (IPLUS (IDIFFERENCE 255 (\BIN STREAM)) THISPIXELERROR)) (PROG1 (SETQ VAL (COND ((IGREATERP BYTE 255) (* overflow case) MAXVALUE) ((IGREATERP 0 BYTE) 0) (T (LRSH BYTE DELBITS)))) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (SETQ ERR (IDIFFERENCE BYTE (\GETBASE INTENSITYBASE VAL))) (* calculate |1/4| of error.) (SETQ ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) 2) 64)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THREEEIGHTSERR (IPLUS ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) 1) 128))) (SETQ THISPIXELERROR (IPLUS (\GETBASEPTR ERRTABLEPTR 2) THREEEIGHTSERR)) (* |1/8| of error to next one down to right.) (\PUTBASEPTR ERRTABLEPTR 2 ERR) (* |3/8| to one below) (\PUTBASEPTR ERRTABLEPTR 0 (IPLUS (\GETBASEPTR ERRTABLEPTR 0) THREEEIGHTSERR)) (SETQ ERRTABLEPTR (\ADDBASE ERRTABLEPTR 2)))))) - -(PUTPROPS .GET.LEFTMOST.4BIT MACRO ((STREAM) (* returns the 4 most significant bits) (LRSH (\BIN STREAM) 4))) - -(PUTPROPS .GET.LEFTMOST.BIT. MACRO ((STREAM) (* returns the most significant bit from an 8 bit sample. It also inverts the sign of the bit since 1 is black and 0 white. NIL) (COND ((IGREATERP (COND (FILTERARRAY (ELT FILTERARRAY (\BIN STREAM))) (T (\BIN STREAM))) 127) 0) (T 1)))) - -(PUTPROPS .GET.BESTCOLOR.AND.SPREAD.ERR. MACRO (NIL (PROGN (* returns the best matching color bits taking into account the error and spreads the error into the appropriate places.) (SETQ COLOR (CLOSEST.COLOR COLORMAP (SETQ REDBYTE (IPLUS (\BIN REDSTREAM) THISPIXELREDERROR)) (SETQ GREENBYTE (IPLUS (\BIN GREENSTREAM) THISPIXELGREENERROR)) (SETQ BLUEBYTE (IPLUS (\BIN BLUESTREAM) THISPIXELBLUEERROR)))) (SETQ RGB (ELT COLORMAP COLOR)) (PROGN (SETQ ERR (IDIFFERENCE (fetch (RGB RED) of RGB) REDBYTE)) (COND ((IGREATERP ERR -1) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELREDERROR (IPLUS (\GETBASEPTR REDERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR REDERRTABLEPTR 2 (LRSH ERR 1)) (* |3/8| to one below) (\PUTBASEPTR REDERRTABLEPTR 0 (IPLUS (\GETBASEPTR REDERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1))))) (T (* error is negative, do things differently.) (* calculate |1/4| of error.) (SETQ ERR (LRSH (IMINUS ERR) 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELREDERROR (IDIFFERENCE (\GETBASEPTR REDERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR REDERRTABLEPTR 2 (IMINUS (LRSH ERR 1))) (* |3/8| to one below) (\PUTBASEPTR REDERRTABLEPTR 0 (IDIFFERENCE (\GETBASEPTR REDERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1)))))) (SETQ REDERRTABLEPTR (\ADDBASE REDERRTABLEPTR 2))) (PROGN (SETQ ERR (IDIFFERENCE (fetch (RGB GREEN) of RGB) GREENBYTE)) (COND ((IGREATERP ERR -1) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELGREENERROR (IPLUS (\GETBASEPTR GREENERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR GREENERRTABLEPTR 2 (LRSH ERR 1)) (* |3/8| to one below) (\PUTBASEPTR GREENERRTABLEPTR 0 (IPLUS (\GETBASEPTR GREENERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1))))) (T (* error is negative, do things differently.) (* calculate |1/4| of error.) (SETQ ERR (LRSH (IMINUS ERR) 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELGREENERROR (IDIFFERENCE (\GETBASEPTR GREENERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR GREENERRTABLEPTR 2 (IMINUS (LRSH ERR 1))) (* |3/8| to one below) (\PUTBASEPTR GREENERRTABLEPTR 0 (IDIFFERENCE (\GETBASEPTR GREENERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1)))))) (SETQ GREENERRTABLEPTR (\ADDBASE GREENERRTABLEPTR 2))) (PROGN (SETQ ERR (IDIFFERENCE (fetch (RGB BLUE) of RGB) BLUEBYTE)) (COND ((IGREATERP ERR -1) (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below and to the right.) (* calculate |1/4| of error.) (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELBLUEERROR (IPLUS (\GETBASEPTR BLUEERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR BLUEERRTABLEPTR 2 (LRSH ERR 1)) (* |3/8| to one below) (\PUTBASEPTR BLUEERRTABLEPTR 0 (IPLUS (\GETBASEPTR BLUEERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1))))) (T (* error is negative, do things differently.) (* calculate |1/4| of error.) (SETQ ERR (LRSH (IMINUS ERR) 2)) (* |3/8| of error to next pixel plus error from previous line) (SETQ THISPIXELBLUEERROR (IDIFFERENCE (\GETBASEPTR BLUEERRTABLEPTR 2) (IPLUS ERR (LRSH ERR 1)))) (* |1/8| of error to next one down to right.) (\PUTBASEPTR BLUEERRTABLEPTR 2 (IMINUS (LRSH ERR 1))) (* |3/8| to one below) (\PUTBASEPTR BLUEERRTABLEPTR 0 (IDIFFERENCE (\GETBASEPTR BLUEERRTABLEPTR 0) (IPLUS ERR (LRSH ERR 1)))))) (SETQ BLUEERRTABLEPTR (\ADDBASE BLUEERRTABLEPTR 2))) COLOR))) - -(PUTPROPS .4BIT.MODULATE.INTENSITY.VALUE. MACRO ((STREAM) (LOGAND (IMIN 255 (IMAX (IPLUS (\BIN STREAM) (RAND MODMIN MODMAX)) 0)) 240))) - -(PUTPROPS .MODULATE.INTENSITY.VALUE. MACRO ((STREAM) (IMIN 255 (IMAX (IPLUS (\BIN STREAM) (RAND MODMIN MODMAX)) 0)))) - -(PUTPROPS SQUARE MACRO (LAMBDA (X) (* coded this way because negative arith is not is microcode for ITIMES) (COND ((IGREATERP X -1) (ITIMES X X)) (T (ITIMES (SETQ X (IMINUS X)) X))))) +(PUTPROPS .GET.4BIT.AND.SPREAD.ERR. MACRO [(STREAM) + (PROGN + + (* returns the 4 most significant bits taking into account the error and spreads + the error into the appropriate places.) + + (SETQ BYTE (IPLUS (\BIN STREAM) + THISPIXELERROR)) + (PROG1 (COND + ((IGREATERP BYTE 255) + (* overflow case) + 15) + (T (LRSH BYTE 4))) + (SETQ ERR (LOGAND BYTE 15)) + + (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below + and to the right.) + (* calculate |1/4| of error.) + (SETQ ERR (LRSH ERR 2)) + (* |3/8| of error to next pixel plus + error from previous line) + [SETQ THISPIXELERROR + (IPLUS (\GETBASE ERRTABLEPTR 1) + (IPLUS ERR (LRSH ERR 1] + (* |1/8| of error to next one down to + right.) + (\PUTBASE ERRTABLEPTR 1 (LRSH ERR 1)) + (* |3/8| to one below) + [\PUTBASE ERRTABLEPTR 0 + (IPLUS (\GETBASE ERRTABLEPTR 0) + (IPLUS ERR (LRSH ERR 1] + (SETQ ERRTABLEPTR (\ADDBASE ERRTABLEPTR 1)))]) + +(PUTPROPS .GET.1BIT.AND.SPREAD.ERR. MACRO [(STREAM) + (PROGN + + (* returns the most significant bit taking into account the error and spreads the + error into the appropriate places.) + + (SETQ BYTE (IPLUS (\BIN STREAM) + THISPIXELERROR)) + (PROG1 [SETQ VAL (COND + ((IGREATERP BYTE 255) + (* overflow case) + 0) + ((IGREATERP 0 BYTE) + (* overflow case) + 1) + (T (LOGXOR (LRSH BYTE 7) + 1] + (SETQ ERR (IDIFFERENCE BYTE (\GETBASE + INTENSITYBASE + VAL))) + + (* put |3/8| of error into next pixel, |3/8| to one below and |1/4| to one below + and to the right.) + (* calculate |1/4| of error.) + (SETQ ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) + 2) + 64)) + (* |3/8| of error to next pixel plus + error from previous line) + (SETQ THREEEIGHTSERR + (IPLUS ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) + 1) + 128))) + (SETQ THISPIXELERROR (IPLUS (\GETBASEPTR + ERRTABLEPTR + 2) + THREEEIGHTSERR)) + (* |1/4| of error to next one down to + right.) + (\PUTBASEPTR ERRTABLEPTR 2 ERR) + (* |3/8| to one below) + (\PUTBASEPTR ERRTABLEPTR 0 + (IPLUS (\GETBASEPTR ERRTABLEPTR 0) + THREEEIGHTSERR)) + (SETQ ERRTABLEPTR (\ADDBASE ERRTABLEPTR 2)))]) + +(PUTPROPS .GET.NBIT.AND.SPREAD.ERR. MACRO [(STREAM) + (PROGN + + (* returns the NBITS most significant bits taking into account the error and + spreads the error into the appropriate places.) + + (SETQ BYTE (IPLUS (IDIFFERENCE 255 (\BIN STREAM)) + THISPIXELERROR)) + (PROG1 [SETQ VAL (COND + ((IGREATERP BYTE 255) + (* overflow case) + MAXVALUE) + ((IGREATERP 0 BYTE) + 0) + (T (LRSH BYTE DELBITS] + + (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below + and to the right.) + + (SETQ ERR (IDIFFERENCE BYTE (\GETBASE + INTENSITYBASE + VAL))) + (* calculate |1/4| of error.) + (SETQ ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) + 2) + 64)) + (* |3/8| of error to next pixel plus + error from previous line) + (SETQ THREEEIGHTSERR + (IPLUS ERR (IDIFFERENCE (LRSH (IPLUS 256 ERR) + 1) + 128))) + (SETQ THISPIXELERROR (IPLUS (\GETBASEPTR + ERRTABLEPTR + 2) + THREEEIGHTSERR)) + (* |1/8| of error to next one down to + right.) + (\PUTBASEPTR ERRTABLEPTR 2 ERR) + (* |3/8| to one below) + (\PUTBASEPTR ERRTABLEPTR 0 + (IPLUS (\GETBASEPTR ERRTABLEPTR 0) + THREEEIGHTSERR)) + (SETQ ERRTABLEPTR (\ADDBASE ERRTABLEPTR 2)))]) + +(PUTPROPS .GET.LEFTMOST.4BIT MACRO ((STREAM) (* returns the 4 most significant bits) + (LRSH (\BIN STREAM) + 4))) + +(PUTPROPS .GET.LEFTMOST.BIT. MACRO ((STREAM) + + (* returns the most significant bit from an 8 bit sample. + It also inverts the sign of the bit since 1 is black and 0 white. + NIL) + + (COND + ((IGREATERP (COND + (FILTERARRAY (ELT FILTERARRAY (\BIN STREAM))) + (T (\BIN STREAM))) + 127) + 0) + (T 1)))) + +(PUTPROPS .GET.BESTCOLOR.AND.SPREAD.ERR. MACRO + (NIL (PROGN + + (* returns the best matching color bits taking into account the error and spreads + the error into the appropriate places.) + + [SETQ COLOR (CLOSEST.COLOR COLORMAP (SETQ REDBYTE (IPLUS (\BIN REDSTREAM) + THISPIXELREDERROR)) + (SETQ GREENBYTE (IPLUS (\BIN GREENSTREAM) + THISPIXELGREENERROR)) + (SETQ BLUEBYTE (IPLUS (\BIN BLUESTREAM) + THISPIXELBLUEERROR] + (SETQ RGB (ELT COLORMAP COLOR)) + (PROGN (SETQ ERR (IDIFFERENCE (fetch (RGB RED) of RGB) + REDBYTE)) + [COND + [(IGREATERP ERR -1) + + (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below + and to the right.) + (* calculate |1/4| of error.) + (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus + error from previous line) + [SETQ THISPIXELREDERROR (IPLUS (\GETBASEPTR REDERRTABLEPTR 2) + (IPLUS ERR (LRSH ERR 1] + (* |1/8| of error to next one down to + right.) + (\PUTBASEPTR REDERRTABLEPTR 2 (LRSH ERR 1)) + (* |3/8| to one below) + (\PUTBASEPTR REDERRTABLEPTR 0 (IPLUS (\GETBASEPTR REDERRTABLEPTR 0) + (IPLUS ERR (LRSH ERR 1] + (T (* error is negative, do things + differently.) + (* calculate |1/4| of error.) + (SETQ ERR (LRSH (IMINUS ERR) + 2)) (* |3/8| of error to next pixel plus + error from previous line) + [SETQ THISPIXELREDERROR (IDIFFERENCE (\GETBASEPTR REDERRTABLEPTR 2 + ) + (IPLUS ERR (LRSH ERR 1] + (* |1/8| of error to next one down to + right.) + (\PUTBASEPTR REDERRTABLEPTR 2 (IMINUS (LRSH ERR 1))) + (* |3/8| to one below) + (\PUTBASEPTR REDERRTABLEPTR 0 (IDIFFERENCE (\GETBASEPTR + REDERRTABLEPTR 0 + ) + (IPLUS ERR (LRSH ERR 1] + (SETQ REDERRTABLEPTR (\ADDBASE REDERRTABLEPTR 2))) + (PROGN (SETQ ERR (IDIFFERENCE (fetch (RGB GREEN) of RGB) + GREENBYTE)) + [COND + [(IGREATERP ERR -1) + + (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below + and to the right.) + (* calculate |1/4| of error.) + (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus + error from previous line) + [SETQ THISPIXELGREENERROR (IPLUS (\GETBASEPTR GREENERRTABLEPTR 2) + (IPLUS ERR (LRSH ERR 1] + (* |1/8| of error to next one down to + right.) + (\PUTBASEPTR GREENERRTABLEPTR 2 (LRSH ERR 1)) + (* |3/8| to one below) + (\PUTBASEPTR GREENERRTABLEPTR 0 (IPLUS (\GETBASEPTR GREENERRTABLEPTR + 0) + (IPLUS ERR (LRSH ERR 1] + (T (* error is negative, do things + differently.) + (* calculate |1/4| of error.) + (SETQ ERR (LRSH (IMINUS ERR) + 2)) (* |3/8| of error to next pixel plus + error from previous line) + [SETQ THISPIXELGREENERROR (IDIFFERENCE (\GETBASEPTR + GREENERRTABLEPTR 2) + (IPLUS ERR (LRSH ERR 1] + (* |1/8| of error to next one down to + right.) + (\PUTBASEPTR GREENERRTABLEPTR 2 (IMINUS (LRSH ERR 1))) + (* |3/8| to one below) + (\PUTBASEPTR GREENERRTABLEPTR 0 (IDIFFERENCE (\GETBASEPTR + GREENERRTABLEPTR + 0) + (IPLUS ERR (LRSH ERR 1] + (SETQ GREENERRTABLEPTR (\ADDBASE GREENERRTABLEPTR 2))) + (PROGN (SETQ ERR (IDIFFERENCE (fetch (RGB BLUE) of RGB) + BLUEBYTE)) + [COND + [(IGREATERP ERR -1) + + (* put |3/8| of error into next pixel, |3/8| to one below and |1/8| to one below + and to the right.) + (* calculate |1/4| of error.) + (SETQ ERR (LRSH ERR 2)) (* |3/8| of error to next pixel plus + error from previous line) + [SETQ THISPIXELBLUEERROR (IPLUS (\GETBASEPTR BLUEERRTABLEPTR 2) + (IPLUS ERR (LRSH ERR 1] + (* |1/8| of error to next one down to + right.) + (\PUTBASEPTR BLUEERRTABLEPTR 2 (LRSH ERR 1)) + (* |3/8| to one below) + (\PUTBASEPTR BLUEERRTABLEPTR 0 (IPLUS (\GETBASEPTR BLUEERRTABLEPTR 0 + ) + (IPLUS ERR (LRSH ERR 1] + (T (* error is negative, do things + differently.) + (* calculate |1/4| of error.) + (SETQ ERR (LRSH (IMINUS ERR) + 2)) (* |3/8| of error to next pixel plus + error from previous line) + [SETQ THISPIXELBLUEERROR (IDIFFERENCE (\GETBASEPTR BLUEERRTABLEPTR + 2) + (IPLUS ERR (LRSH ERR 1] + (* |1/8| of error to next one down to + right.) + (\PUTBASEPTR BLUEERRTABLEPTR 2 (IMINUS (LRSH ERR 1))) + (* |3/8| to one below) + (\PUTBASEPTR BLUEERRTABLEPTR 0 (IDIFFERENCE (\GETBASEPTR + BLUEERRTABLEPTR + 0) + (IPLUS ERR (LRSH ERR 1] + (SETQ BLUEERRTABLEPTR (\ADDBASE BLUEERRTABLEPTR 2))) + COLOR))) + +(PUTPROPS .4BIT.MODULATE.INTENSITY.VALUE. MACRO ((STREAM) + (LOGAND (IMIN 255 (IMAX (IPLUS (\BIN STREAM) + (RAND MODMIN MODMAX)) + 0)) + 240))) + +(PUTPROPS .MODULATE.INTENSITY.VALUE. MACRO ((STREAM) + (IMIN 255 (IMAX (IPLUS (\BIN STREAM) + (RAND MODMIN MODMAX)) + 0)))) + +(PUTPROPS SQUARE MACRO [LAMBDA (X) (* coded this way because negative + arith is not is microcode for ITIMES) + (COND + ((IGREATERP X -1) + (ITIMES X X)) + (T (ITIMES (SETQ X (IMINUS X)) + X]) ) -(MOVD? (QUOTE FAST.COLOR.DISTANCE) (QUOTE COLOR.DISTANCE)) +(MOVD? 'FAST.COLOR.DISTANCE 'COLOR.DISTANCE) -(RPAQQ AISDIRECTORIES (T {CORE} {DSK} {CYAN})) +(RPAQQ AISDIRECTORIES (T {CORE} {DSK} {CYAN})) (DECLARE%: DOEVAL@COMPILE DONTCOPY - (GLOBALVARS AISDIRECTORIES) ) (PUTPROPS READAIS COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1827 40089 (24BITCOLORTO8BITMAP 1837 . 3843) (AISBLT 3845 . 10524) (AISBLT1TO1 10526 . -11817) (AISBLT8TO4MODUL 11819 . 13524) (AISBLT8TOLESSFSA 13526 . 15610) (AISBLT8TO4TRUNC 15612 . 16848 -) (AISBLT8TO8 16850 . 19104) (AISBLT4TO4 19106 . 21591) (AISBLT8TO4LESSFSA 21593 . 23620) ( -AISBLT8TO1FSA 23622 . 26181) (AISBLT8TO1TRUNC 26183 . 27872) (CLOSEST.COLOR 27874 . 28236) ( -GRAPHAISHISTOGRAM 28238 . 28847) (AISHISTOGRAM 28849 . 30585) (SMOOTHEDFILTER 30587 . 31648) ( -SLOW.COLOR.DISTANCE 31650 . 31948) (FAST.COLOR.DISTANCE 31950 . 32242) (INSUREAISFILE 32244 . 33441) ( -SHOWCOLORAIS 33443 . 35628) (SHOWCOLORAIS1 35630 . 37166) (WRITEAIS 37168 . 39031) (WRITEAIS1 39033 . -39353) (\GETBASENYBBLE 39355 . 39642) (\PUTBASENYBBLE 39644 . 40087))))) + (FILEMAP (NIL (1582 41465 (24BITCOLORTO8BITMAP 1592 . 3598) (AISBLT 3600 . 10279) (AISBLT1TO1 10281 . +11572) (AISBLT8TO4MODUL 11574 . 13279) (AISBLT8TOLESSFSA 13281 . 15365) (AISBLT8TO4TRUNC 15367 . 16603 +) (AISBLT8TO8 16605 . 18859) (AISBLT4TO4 18861 . 21346) (AISBLT8TO4LESSFSA 21348 . 23375) ( +AISBLT8TO1FSA 23377 . 25936) (AISBLT8TO1TRUNC 25938 . 27627) (CLOSEST.COLOR 27629 . 27991) ( +GRAPHAISHISTOGRAM 27993 . 28602) (AISHISTOGRAM 28604 . 31961) (SMOOTHEDFILTER 31963 . 33024) ( +SLOW.COLOR.DISTANCE 33026 . 33324) (FAST.COLOR.DISTANCE 33326 . 33618) (INSUREAISFILE 33620 . 34817) ( +SHOWCOLORAIS 34819 . 37004) (SHOWCOLORAIS1 37006 . 38542) (WRITEAIS 38544 . 40407) (WRITEAIS1 40409 . +40729) (\GETBASENYBBLE 40731 . 41018) (\PUTBASENYBBLE 41020 . 41463))))) STOP diff --git a/lispusers/READAIS.LCOM b/lispusers/READAIS.LCOM index 78920ee10..1f558c6f3 100644 Binary files a/lispusers/READAIS.LCOM and b/lispusers/READAIS.LCOM differ diff --git a/lispusers/READINTERPRESS b/lispusers/READINTERPRESS index e64e99640..0bc37aedc 100644 --- a/lispusers/READINTERPRESS +++ b/lispusers/READINTERPRESS @@ -1,11 +1,12 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "22-Jun-2021 10:52:34"  -{DSK}kaplan>Local>medley3.5>git-medley>lispusers>READINTERPRESS.;4 10412 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS PRINTSEQUENCE) +(FILECREATED "24-Sep-2023 13:52:48" {WMEDLEY}READINTERPRESS.;6 11350 - previous date%: "22-Jun-2021 10:35:30" -{DSK}kaplan>Local>medley3.5>git-medley>lispusers>READINTERPRESS.;3) + :EDIT-BY rmk + + :CHANGES-TO (FNS SHOWFILE) + + :PREVIOUS-DATE "22-Jun-2021 10:52:34" {WMEDLEY}READINTERPRESS.;4) (* ; " @@ -122,8 +123,53 @@ Copyright (c) 1983-1986, 1988, 2021 by Xerox Corporation. ) (SHOWFILE -(LAMBDA (IPFILE OUTPUTFILE MAXZEROLINES) (* rmk%: "16-Jun-84 15:29") (OR MAXZEROLINES (SETQ MAXZEROLINES 5)) (RESETLST (PROG (STREAM) (RESETSAVE (SETQ STREAM (OPENFILE IPFILE (QUOTE INPUT))) (QUOTE (PROGN (CLOSEF? OLDVALUE)))) (SETQ STREAM (GETSTREAM STREAM)) (* Don't do an OPENSTREAM until (OPENP stream) is NIL if stream is closed.) (RESETSAVE (OUTPUT)) (RESETSAVE (SETQ OUTPUTFILE (OPENFILE OUTPUTFILE (QUOTE OUTPUT))) (QUOTE (PROGN (CLOSEF? OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE))))) (OUTPUT OUTPUTFILE) (printout NIL .FONT DEFAULTFONT (OPENP STREAM (QUOTE INPUT)) T T) (for I B1 B2 B3 B4 B5 B6 B7 B8 (NZEROLINES _ 0) from 1 by 8 until (\EOFP STREAM) do (printout NIL |.I5| I %,,) (SETQ B1 (SHOWBYTE STREAM)) (SETQ B2 (SHOWBYTE STREAM)) (SETQ B3 (SHOWBYTE STREAM)) (SETQ B4 (SHOWBYTE STREAM)) (printout NIL %,,) (SETQ B5 (SHOWBYTE STREAM)) (SETQ B6 (SHOWBYTE STREAM)) (SETQ B7 (SHOWBYTE STREAM)) (SETQ B8 (SHOWBYTE STREAM)) (TAB 23) (COND (B1 (printout NIL |.I4| B1))) (COND (B2 (printout NIL |.I4| B2))) (COND (B3 (printout NIL |.I4| B3))) (COND (B4 (printout NIL |.I4| B4))) (printout NIL %,,) (COND (B5 (printout NIL |.I4| B5))) (COND (B6 (printout NIL |.I4| B6))) (COND (B7 (printout NIL |.I4| B7))) (COND (B8 (printout NIL |.I4| B8 T)))) (RETURN (LIST (CLOSEF IPFILE) (CLOSEF OUTPUTFILE)))))) -) + [LAMBDA (IPFILE OUTPUTFILE MAXZEROLINES) (* ; "Edited 24-Sep-2023 13:52 by rmk") + (* rmk%: "16-Jun-84 15:29") + (OR MAXZEROLINES (SETQ MAXZEROLINES 5)) + (RESETLST + [PROG (STREAM) + [RESETSAVE (SETQ STREAM (OPENSTREAM IPFILE 'INPUT)) + '(PROGN (CLOSEF? OLDVALUE] (* Don't do an OPENSTREAM until + (OPENP stream) is NIL if stream is + closed.) + (RESETSAVE (OUTPUT)) + [RESETSAVE (SETQ OUTPUTFILE (OPENSTREAM OUTPUTFILE 'OUTPUT)) + '(PROGN (CLOSEF? OLDVALUE) + (AND RESETSTATE (DELFILE OLDVALUE] + (OUTPUT OUTPUTFILE) + (printout NIL .FONT DEFAULTFONT (OPENP STREAM 'INPUT) + T T) + [for I B1 B2 B3 B4 B5 B6 B7 B8 (NZEROLINES _ 0) from 1 by 8 until (\EOFP STREAM) + do (printout NIL .I5 I %,,) + (SETQ B1 (SHOWBYTE STREAM)) + (SETQ B2 (SHOWBYTE STREAM)) + (SETQ B3 (SHOWBYTE STREAM)) + (SETQ B4 (SHOWBYTE STREAM)) + (printout NIL %,,) + (SETQ B5 (SHOWBYTE STREAM)) + (SETQ B6 (SHOWBYTE STREAM)) + (SETQ B7 (SHOWBYTE STREAM)) + (SETQ B8 (SHOWBYTE STREAM)) + (TAB 23) + (COND + (B1 (printout NIL .I4 B1))) + (COND + (B2 (printout NIL .I4 B2))) + (COND + (B3 (printout NIL .I4 B3))) + (COND + (B4 (printout NIL .I4 B4))) + (printout NIL %,,) + (COND + (B5 (printout NIL .I4 B5))) + (COND + (B6 (printout NIL .I4 B6))) + (COND + (B7 (printout NIL .I4 B7))) + (COND + (B8 (printout NIL .I4 B8 T] + (RETURN (LIST (CLOSEF IPFILE) + (CLOSEF OUTPUTFILE])]) (SHOWBYTE (LAMBDA (STREAM) (* rmk%: "13-JUL-82 18:01") (PROG ((BYTE (COND ((NOT (\EOFP STREAM)) (\BIN STREAM))))) (COND (BYTE (PRIN1 (COND ((AND (IGEQ BYTE (CHARCODE SPACE)) (ILESSP BYTE (CHARCODE DEL)) (NEQ BYTE 96)) (CHARACTER BYTE)) (T (QUOTE %.)))))) (RETURN BYTE))) @@ -132,14 +178,14 @@ Copyright (c) 1983-1986, 1988, 2021 by Xerox Corporation. (DECLARE%: EVAL@COMPILE (PUTPROPS BIN.RIP MACRO [ARGS (LET ((ISTREAM (CAR ARGS)) - (OSTREAM (CADR ARGS))) - `(LET [(C (BIN ,ISTREAM] - (COND - ((IGREATERP (POSITION ,OSTREAM) - 15) - (printout ,OSTREAM 5 "|" 8))) - (printout ,OSTREAM .I3 C " ") - C]) + (OSTREAM (CADR ARGS))) + `(LET [(C (BIN ,ISTREAM] + (COND + ((IGREATERP (POSITION ,OSTREAM) + 15) + (printout ,OSTREAM 5 "|" 8))) + (printout ,OSTREAM .I3 C " ") + C]) ) (DECLARE%: EVAL@COMPILE DONTCOPY @@ -156,8 +202,9 @@ Copyright (c) 1983-1986, 1988, 2021 by Xerox Corporation. ) (PUTPROPS READINTERPRESS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1988 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1210 1896 (PRINTMASTER 1220 . 1894)) (1897 9430 (OPCODE 1907 . 2032) (TOKEN 2034 . 2606 -) (FINDNONPRIMNAME 2608 . 2713) (FINDOPNAME 2715 . 2972) (SHORTINT 2974 . 3167) (TOKENFORMAT 3169 . -3411) (FINDSEQUENCETYPE 3413 . 3617) (PRINTTOKEN 3619 . 4570) (PRINTSEQUENCE 4572 . 7449) ( -SEARCHIPLIST 7451 . 7583) (READINT.IP 7585 . 7824) (SHOWFILE 7826 . 9150) (SHOWBYTE 9152 . 9428))))) + (FILEMAP (NIL (1158 1844 (PRINTMASTER 1168 . 1842)) (1845 10432 (OPCODE 1855 . 1980) (TOKEN 1982 . +2554) (FINDNONPRIMNAME 2556 . 2661) (FINDOPNAME 2663 . 2920) (SHORTINT 2922 . 3115) (TOKENFORMAT 3117 + . 3359) (FINDSEQUENCETYPE 3361 . 3565) (PRINTTOKEN 3567 . 4518) (PRINTSEQUENCE 4520 . 7397) ( +SEARCHIPLIST 7399 . 7531) (READINT.IP 7533 . 7772) (SHOWFILE 7774 . 10152) (SHOWBYTE 10154 . 10430)))) +) STOP diff --git a/lispusers/READINTERPRESS.LCOM b/lispusers/READINTERPRESS.LCOM index c9323e9b6..06b8e147b 100644 Binary files a/lispusers/READINTERPRESS.LCOM and b/lispusers/READINTERPRESS.LCOM differ diff --git a/lispusers/SHOWTIME b/lispusers/SHOWTIME index 601f12eac..fc797fd51 100644 --- a/lispusers/SHOWTIME +++ b/lispusers/SHOWTIME @@ -1,18 +1,48 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "10-Apr-89 18:56:29" {ERINYES}MEDLEY>SHOWTIME.;1 24672 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS SHOWTIME.READ.LISPBM) +(FILECREATED "24-Sep-2023 14:29:56" {WMEDLEY}SHOWTIME.;2 26541 - previous date%: "13-May-88 16:31:25" {POOH/N}LISP>MEDLEY>LISPUSERS>SHOWTIME;1) + :EDIT-BY rmk + :CHANGES-TO (VARS SHOWTIMECOMS SHOWTIME.ICON SHOWTIME.MASK) + (FNS INFORES SHOWTIME.READ.PRESS) -(* " -Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. + :PREVIOUS-DATE "10-Apr-89 18:56:29" {WMEDLEY}SHOWTIME.;1) + + +(* ; " +Copyright (c) 1986-1989 by Xerox Corporation. ") (PRETTYCOMPRINT SHOWTIMECOMS) -(RPAQQ SHOWTIMECOMS ((* ;;; "Mitch Gaarnat and (Mike?) Gocek wrote the original versions of these fns in 1985. They were later modified added to by T. Bigham in 1986 and 1987. Ron Fischer at Xerox AI Systems made a quick pass to convert the file to run in Medley XAIE.") (FNS GET.SHOWTIME.MENU MAKEBRUSH MAKEBRUSH.HEADER&BITMAP INFORES READ.RES SHOWTIME SHOWTIME.BUTTONEVENTFN SHOWTIME.GET.NAME SHOWTIME.ICONFN SHOWTIME.LOAD.BITMAP SHOWTIME.LOAD.BRUSH SHOWTIME.LOAD.DIF.FILE SHOWTIME.LOAD.RES.FILE SHOWTIME.MAKE.RES SHOWTIME.MAKE.RES.HEADER SHOWTIME.MAKE.RES.TAIL SHOWTIME.READ.BRUSH SHOWTIME.READ.LISPBM SHOWTIME.READ.PRESS SHOWTIME.READ.RES SHOWTIME.RES.CHECK&MASSAGE SHOWTIME.RESHAPE.WINDOW SHOWTIME.SAVE.BITMAP SHOWTIME.SAVE.LISPBM SHOWTIME.SCALE.BITMAP SHOWTIME.ADD.FORMAT SHOWTIME.SETUP.WINDOWPROPS SHOWTIME.SHOW.BITMAP SHOWTIME.WRITEBM) (VARS SHOWTIME.ICON SHOWTIME.MASK (SHOWTIME.LOAD.SUBITEMS) (SHOWTIME.SAVE.SUBITEMS) (SHOWTIME.MENU) (SHOWTIMETITLEREGION (QUOTE (7 7 56 29))) (SHOWTIME.DEFAULT.FORMAT (QUOTE LISP)) (BackgroundMenu) (SHOWTIME.FORMAT.FNS (QUOTE (SHOWTIME.FORMAT.FNS (RES READ.RES SHOWTIME.MAKE.RES) (LISP SHOWTIME.READ.LISPBM SHOWTIME.SAVE.LISPBM) (DIF SHOWTIME.LOAD.DIF.FILE NIL) (BRUSH SHOWTIME.LOAD.BRUSH MAKEBRUSH) (PRESS READPRESS PRESSBITMAP))))) (APPENDVARS (BackgroundMenuCommands (Showtime (QUOTE (SHOWTIME)) "Opens a showtime window for use."))) (FILES BITMAPFNS SCALEBITMAP READBRUSH) (P (SHOWTIME.ADD.FORMAT)))) +(RPAQQ SHOWTIMECOMS + ( + +(* ;;; "Mitch Gaarnat and (Mike?) Gocek wrote the original versions of these fns in 1985. They were later modified added to by T. Bigham in 1986 and 1987. Ron Fischer at Xerox AI Systems made a quick pass to convert the file to run in Medley XAIE.") + + (FNS GET.SHOWTIME.MENU MAKEBRUSH MAKEBRUSH.HEADER&BITMAP INFORES READ.RES SHOWTIME + SHOWTIME.BUTTONEVENTFN SHOWTIME.GET.NAME SHOWTIME.ICONFN SHOWTIME.LOAD.BITMAP + SHOWTIME.LOAD.BRUSH SHOWTIME.LOAD.DIF.FILE SHOWTIME.LOAD.RES.FILE SHOWTIME.MAKE.RES + SHOWTIME.MAKE.RES.HEADER SHOWTIME.MAKE.RES.TAIL SHOWTIME.READ.BRUSH SHOWTIME.READ.LISPBM + SHOWTIME.READ.PRESS SHOWTIME.READ.RES SHOWTIME.RES.CHECK&MASSAGE SHOWTIME.RESHAPE.WINDOW + SHOWTIME.SAVE.BITMAP SHOWTIME.SAVE.LISPBM SHOWTIME.SCALE.BITMAP SHOWTIME.ADD.FORMAT + SHOWTIME.SETUP.WINDOWPROPS SHOWTIME.SHOW.BITMAP SHOWTIME.WRITEBM) + [VARS SHOWTIME.ICON SHOWTIME.MASK (SHOWTIME.LOAD.SUBITEMS) + (SHOWTIME.SAVE.SUBITEMS) + (SHOWTIME.MENU) + (SHOWTIMETITLEREGION '(7 7 56 29)) + (SHOWTIME.DEFAULT.FORMAT 'LISP) + (BackgroundMenu) + (SHOWTIME.FORMAT.FNS '(SHOWTIME.FORMAT.FNS (RES READ.RES SHOWTIME.MAKE.RES) + (LISP SHOWTIME.READ.LISPBM SHOWTIME.SAVE.LISPBM) + (DIF SHOWTIME.LOAD.DIF.FILE NIL) + (BRUSH SHOWTIME.LOAD.BRUSH MAKEBRUSH) + (PRESS READPRESS PRESSBITMAP] + (APPENDVARS (BackgroundMenuCommands (Showtime '(SHOWTIME) + "Opens a showtime window for use."))) + (FILES BITMAPFNS SCALEBITMAP READBRUSH) + (P (SHOWTIME.ADD.FORMAT)))) @@ -35,8 +65,35 @@ Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ) (INFORES -(LAMBDA (FILE) (* ; "Edited 13-May-88 16:01 by raf") (LET (STREAM PATTERN WIDTH HEIGHT HI.X LO.X HI.Y LO.Y REAL.X REAL.Y (Header (QUOTE Interpress/Xerox/2.1/RasterEncoding/1.0% ))) (* ; "Return the width, height, bits per pixel and address of the first data byte as a list.") (SETQ STREAM (GETSTREAM (OPENFILE FILE (QUOTE INPUT)) (QUOTE INPUT))) (if (EQ Header (PACK (for X from 1 to 40 collect (CHARACTER (\BIN STREAM))))) then (* ; "bypass BEGIN 254/720000 DUP 2 MAKEVEC") (until (EQUAL (NTH (REVERSE PATTERN) (IDIFFERENCE (LENGTH PATTERN) 4)) (QUOTE (181 15 162 161 27))) do (SETQ PATTERN (push PATTERN (\BIN STREAM)))) (SETQ HI.X (\BIN STREAM)) (SETQ LO.X (\BIN STREAM)) (SETQ HI.Y (\BIN STREAM)) (SETQ LO.Y (\BIN STREAM)) (SETQ REAL.X (IDIFFERENCE (PLUS (LSH HI.X 8) LO.X) 4000)) (SETQ REAL.Y (IDIFFERENCE (PLUS (LSH HI.Y 8) LO.Y) 4000)) (LIST REAL.X REAL.Y STREAM) else (CLOSEF STREAM) NIL))) -) + [LAMBDA (FILE) (* ; "Edited 24-Sep-2023 14:28 by rmk") + (* ; "Edited 13-May-88 16:01 by raf") + (LET (STREAM PATTERN WIDTH HEIGHT HI.X LO.X HI.Y LO.Y REAL.X REAL.Y (Header + ' + Interpress/Xerox/2.1/RasterEncoding/1.0% + )) + (* ; + "Return the width, height, bits per pixel and address of the first data byte as a list.") + (SETQ STREAM (OPENSTREAM FILE 'INPUT)) + (if [EQ Header (PACK (for X from 1 to 40 collect (CHARACTER (\BIN STREAM] + then (* ; + "bypass BEGIN 254/720000 DUP 2 MAKEVEC") + [until (EQUAL (NTH (REVERSE PATTERN) + (IDIFFERENCE (LENGTH PATTERN) + 4)) + '(181 15 162 161 27)) do (SETQ PATTERN (push PATTERN (\BIN STREAM] + (SETQ HI.X (\BIN STREAM)) + (SETQ LO.X (\BIN STREAM)) + (SETQ HI.Y (\BIN STREAM)) + (SETQ LO.Y (\BIN STREAM)) + (SETQ REAL.X (IDIFFERENCE (PLUS (LSH HI.X 8) + LO.X) + 4000)) + (SETQ REAL.Y (IDIFFERENCE (PLUS (LSH HI.Y 8) + LO.Y) + 4000)) + (LIST REAL.X REAL.Y STREAM) + else (CLOSEF STREAM) + NIL]) (READ.RES (LAMBDA (FILE) (* ; "Edited 13-May-88 16:02 by raf") (LET (STREAM A B BITMAP BASE WORDS Attributes WIDTH HEIGHT) (if (SETQ FILE (FULLNAME FILE)) then (* ; "If the file exists, check to see if it's RES format.") (if (SETQ Attributes (INFORES FILE)) then (SETQ WIDTH (CAR Attributes)) (SETQ HEIGHT (CADR Attributes)) (SETQ STREAM (CADDR Attributes)) (SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT 1)) (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (* ; "RESINFO leaves the file open at byte 62.0 Image data begins at byte 95") (for X from 63 to 94 do (\BIN STREAM)) (for X from 1 to (IQUOTIENT (ITIMES WIDTH HEIGHT) 16) do (SETQ A (\BIN STREAM)) (SETQ B (\BIN STREAM)) (\PUTBASE BASE 0 (LOGOR (LLSH A 8) B)) (SETQ BASE (\ADDBASE BASE 1)) (ZEROP (LOGAND X 1023))) (CLOSEF STREAM) BITMAP else (printout PROMPTWINDOW T FILE "isn't an RES file")) else (printout PROMPTWINDOW T "Can't find " FILE) NIL))) @@ -93,7 +150,9 @@ Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ) (SHOWTIME.READ.PRESS -(LAMBDA (FILENAME) (* TBigham "30-Dec-86 11:59") (READPRESS (OPENFILE FILENAME (QUOTE INPUT))))) + [LAMBDA (FILENAME) (* ; "Edited 24-Sep-2023 14:29 by rmk") + (* TBigham "30-Dec-86 11:59") + (READPRESS FILENAME]) (SHOWTIME.READ.RES (LAMBDA (FILENAME) (* TBigham "30-Dec-86 12:03") (* load an RES image and makes it into a lisp bitmap) (DECLARE (GLOBALVARS WAITINGCURSOR)) (LET (BITMAP) (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (SETQ BITMAP (READ.RES FILENAME))))) @@ -136,41 +195,48 @@ Copyright (c) 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ) ) -(RPAQQ SHOWTIME.ICON #*(80 84)@C@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@@@@@@@@@@COO@@@@@@@@@@@@@@@@@CMOO@@@@@@@@@@@@@@@@GLAOO@@@@@@@@@@@@@@@GL@AOO@@@@@@@@@@@@@@GN@@OOO@@@@@@@@@@@@@GN@@OOOO@@@@@@@@@@@@ON@@GOMOO@@@@@@@@@@@ON@@GOLAOO@@@@@@@@@@OO@@GOL@AOO@@@@@@@@@OO@@GON@@OOO@@@@@@@AOO@@CON@@OOOO@@@@@@AOO@@CON@@GOMOO@@@@@AOOH@CON@@GOLAOO@@@@AOOH@COO@@GOL@AOO@@@AOOH@AOO@@GON@@OOO@@@AOO@AOO@@CON@@OOOO@@@AOOAOO@@CON@@OOMOO@@@AOOOOH@CON@@GOLAO@@@@AOOOH@COO@@GOL@C@@@@@AOOH@AOO@@GON@C@@@@@@AOO@AOO@@GON@G@@@@@@@AOOAOO@@CON@F@@@@@@@@AOOOOH@CON@F@@@@@@@@@AOOOH@COO@F@@@@@@@@@@AOOH@COO@N@@@@@@@@@@@AOO@AOO@L@@@@@@@@@@@@AOOAOO@L@@@@@@@@@@@@@AOOOOHL@@@@@@@@@@@@@@AOOOIL@@@@@@@@@@@@@@@AOOIH@@@@@@@@@@@@@@@@AOIH@@@@@@@@@@@@@@@@@AOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOHGALF@LGLD@DDOND@GHOGKKNMOFONMKFNGLNOGHOGOKNMOFNNOKNNCHNOOHOGOKNMOFFLOKNNKJNOOHOHGH@MOGFMOKNNIBN@OHOOKKNMOGFMOKNNMFNOOHOOKKNMOG@AOKNNLFNOOHOGKKNMOGKKOKNNNNNOGHOHGALF@OKKOALDGLD@GHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOH) +(RPAQQ SHOWTIME.ICON #*(80 84)@C@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@@@@@@@@@@COO@@@@@@@@@@@@@@@@@CMOO@@@@@@@@@@@@@@@@GLAOO@@@@@@@@@@@@@@@GL@AOO@@@@@@@@@@@@@@GN@@OOO@@@@@@@@@@@@@GN@@OOOO@@@@@@@@@@@@ON@@GOMOO@@@@@@@@@@@ON@@GOLAOO@@@@@@@@@@OO@@GOL@AOO@@@@@@@@@OO@@GON@@OOO@@@@@@@AOO@@CON@@OOOO@@@@@@AOO@@CON@@GOMOO@@@@@AOOH@CON@@GOLAOO@@@@AOOH@COO@@GOL@AOO@@@AOOH@AOO@@GON@@OOO@@@AOO@AOO@@CON@@OOOO@@@AOOAOO@@CON@@OOMOO@@@AOOOOH@CON@@GOLAO@@@@AOOOH@COO@@GOL@C@@@@@AOOH@AOO@@GON@C@@@@@@AOO@AOO@@GON@G@@@@@@@AOOAOO@@CON@F@@@@@@@@AOOOOH@CON@F@@@@@@@@@AOOOH@COO@F@@@@@@@@@@AOOH@COO@N@@@@@@@@@@@AOO@AOO@L@@@@@@@@@@@@AOOAOO@L@@@@@@@@@@@@@AOOOOHL@@@@@@@@@@@@@@AOOOIL@@@@@@@@@@@@@@@AOOIH@@@@@@@@@@@@@@@@AOIH@@@@@@@@@@@@@@@@@AOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOHGALF@LGLD@DDOND@GHOGKKNMOFONMKFNGLNOGHOGOKNMOFNNOKNNCHNOOHOGOKNMOFFLOKNNKJNOOHOHGH@MOGFMOKNNIBN@OHOOKKNMOGFMOKNNMFNOOHOOKKNMOG@AOKNNLFNOOHOGKKNMOGKKOKNNNNNOGHOHGALF@OKKOALDGLD@GHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@AHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOH +) -(RPAQQ SHOWTIME.MASK #*(80 84)@C@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@@@@@@@@@@COO@@@@@@@@@@@@@@@@@COOO@@@@@@@@@@@@@@@@GOOOO@@@@@@@@@@@@@@@GOOOOO@@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOOO@@@@@@@@@@@@OOOOOOOOO@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@OOOOOOOOOOO@@@@@@@@@OOOOOOOOOOOO@@@@@@@AOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOO@@@@AOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOO@@@@AOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOO@@@@@@@AOOOOOOOOOOON@@@@@@@@AOOOOOOOOOON@@@@@@@@@AOOOOOOOOON@@@@@@@@@@AOOOOOOOON@@@@@@@@@@@AOOOOOOOL@@@@@@@@@@@@AOOOOOOL@@@@@@@@@@@@@AOOOOOL@@@@@@@@@@@@@@AOOOOL@@@@@@@@@@@@@@@AOOOH@@@@@@@@@@@@@@@@AOOH@@@@@@@@@@@@@@@@@AOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOH) +(RPAQQ SHOWTIME.MASK #*(80 84)@C@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@@@@@@@@@@COO@@@@@@@@@@@@@@@@@COOO@@@@@@@@@@@@@@@@GOOOO@@@@@@@@@@@@@@@GOOOOO@@@@@@@@@@@@@@GOOOOOO@@@@@@@@@@@@@GOOOOOOO@@@@@@@@@@@@OOOOOOOOO@@@@@@@@@@@OOOOOOOOOO@@@@@@@@@@OOOOOOOOOOO@@@@@@@@@OOOOOOOOOOOO@@@@@@@AOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOOO@@@@AOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOOO@@@AOOOOOOOOOOOOOOOO@@@@AOOOOOOOOOOOOOOO@@@@@AOOOOOOOOOOOOOO@@@@@@AOOOOOOOOOOOOO@@@@@@@AOOOOOOOOOOON@@@@@@@@AOOOOOOOOOON@@@@@@@@@AOOOOOOOOON@@@@@@@@@@AOOOOOOOON@@@@@@@@@@@AOOOOOOOL@@@@@@@@@@@@AOOOOOOL@@@@@@@@@@@@@AOOOOOL@@@@@@@@@@@@@@AOOOOL@@@@@@@@@@@@@@@AOOOH@@@@@@@@@@@@@@@@AOOH@@@@@@@@@@@@@@@@@AOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOH +) -(RPAQQ SHOWTIME.LOAD.SUBITEMS NIL) +(RPAQQ SHOWTIME.LOAD.SUBITEMS NIL) -(RPAQQ SHOWTIME.SAVE.SUBITEMS NIL) +(RPAQQ SHOWTIME.SAVE.SUBITEMS NIL) -(RPAQQ SHOWTIME.MENU NIL) +(RPAQQ SHOWTIME.MENU NIL) -(RPAQQ SHOWTIMETITLEREGION (7 7 56 29)) +(RPAQQ SHOWTIMETITLEREGION (7 7 56 29)) -(RPAQQ SHOWTIME.DEFAULT.FORMAT LISP) +(RPAQQ SHOWTIME.DEFAULT.FORMAT LISP) -(RPAQQ BackgroundMenu NIL) +(RPAQQ BackgroundMenu NIL) -(RPAQQ SHOWTIME.FORMAT.FNS (SHOWTIME.FORMAT.FNS (RES READ.RES SHOWTIME.MAKE.RES) (LISP SHOWTIME.READ.LISPBM SHOWTIME.SAVE.LISPBM) (DIF SHOWTIME.LOAD.DIF.FILE NIL) (BRUSH SHOWTIME.LOAD.BRUSH MAKEBRUSH) (PRESS READPRESS PRESSBITMAP))) +(RPAQQ SHOWTIME.FORMAT.FNS (SHOWTIME.FORMAT.FNS (RES READ.RES SHOWTIME.MAKE.RES) + (LISP SHOWTIME.READ.LISPBM SHOWTIME.SAVE.LISPBM) + (DIF SHOWTIME.LOAD.DIF.FILE NIL) + (BRUSH SHOWTIME.LOAD.BRUSH MAKEBRUSH) + (PRESS READPRESS PRESSBITMAP))) -(APPENDTOVAR BackgroundMenuCommands (Showtime (QUOTE (SHOWTIME)) "Opens a showtime window for use.") -) +(APPENDTOVAR BackgroundMenuCommands (Showtime '(SHOWTIME) + "Opens a showtime window for use.")) (FILESLOAD BITMAPFNS SCALEBITMAP READBRUSH) -(SHOWTIME.ADD.FORMAT) +(SHOWTIME.ADD.FORMAT) (PUTPROPS SHOWTIME COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2126 20535 (GET.SHOWTIME.MENU 2136 . 2931) (MAKEBRUSH 2933 . 3123) ( -MAKEBRUSH.HEADER&BITMAP 3125 . 3863) (INFORES 3865 . 4778) (READ.RES 4780 . 5689) (SHOWTIME 5691 . -6711) (SHOWTIME.BUTTONEVENTFN 6713 . 8306) (SHOWTIME.GET.NAME 8308 . 9067) (SHOWTIME.ICONFN 9069 . -9407) (SHOWTIME.LOAD.BITMAP 9409 . 10592) (SHOWTIME.LOAD.BRUSH 10594 . 10692) (SHOWTIME.LOAD.DIF.FILE -10694 . 11765) (SHOWTIME.LOAD.RES.FILE 11767 . 12032) (SHOWTIME.MAKE.RES 12034 . 12411) ( -SHOWTIME.MAKE.RES.HEADER 12413 . 14913) (SHOWTIME.MAKE.RES.TAIL 14915 . 15214) (SHOWTIME.READ.BRUSH -15216 . 15322) (SHOWTIME.READ.LISPBM 15324 . 15541) (SHOWTIME.READ.PRESS 15543 . 15664) ( -SHOWTIME.READ.RES 15666 . 15926) (SHOWTIME.RES.CHECK&MASSAGE 15928 . 16392) (SHOWTIME.RESHAPE.WINDOW -16394 . 16681) (SHOWTIME.SAVE.BITMAP 16683 . 17478) (SHOWTIME.SAVE.LISPBM 17480 . 17703) ( -SHOWTIME.SCALE.BITMAP 17705 . 18394) (SHOWTIME.ADD.FORMAT 18396 . 19125) (SHOWTIME.SETUP.WINDOWPROPS -19127 . 19376) (SHOWTIME.SHOW.BITMAP 19378 . 19835) (SHOWTIME.WRITEBM 19837 . 20533))))) + (FILEMAP (NIL (2589 22191 (GET.SHOWTIME.MENU 2599 . 3394) (MAKEBRUSH 3396 . 3586) ( +MAKEBRUSH.HEADER&BITMAP 3588 . 4326) (INFORES 4328 . 6301) (READ.RES 6303 . 7212) (SHOWTIME 7214 . +8234) (SHOWTIME.BUTTONEVENTFN 8236 . 9829) (SHOWTIME.GET.NAME 9831 . 10590) (SHOWTIME.ICONFN 10592 . +10930) (SHOWTIME.LOAD.BITMAP 10932 . 12115) (SHOWTIME.LOAD.BRUSH 12117 . 12215) ( +SHOWTIME.LOAD.DIF.FILE 12217 . 13288) (SHOWTIME.LOAD.RES.FILE 13290 . 13555) (SHOWTIME.MAKE.RES 13557 + . 13934) (SHOWTIME.MAKE.RES.HEADER 13936 . 16436) (SHOWTIME.MAKE.RES.TAIL 16438 . 16737) ( +SHOWTIME.READ.BRUSH 16739 . 16845) (SHOWTIME.READ.LISPBM 16847 . 17064) (SHOWTIME.READ.PRESS 17066 . +17320) (SHOWTIME.READ.RES 17322 . 17582) (SHOWTIME.RES.CHECK&MASSAGE 17584 . 18048) ( +SHOWTIME.RESHAPE.WINDOW 18050 . 18337) (SHOWTIME.SAVE.BITMAP 18339 . 19134) (SHOWTIME.SAVE.LISPBM +19136 . 19359) (SHOWTIME.SCALE.BITMAP 19361 . 20050) (SHOWTIME.ADD.FORMAT 20052 . 20781) ( +SHOWTIME.SETUP.WINDOWPROPS 20783 . 21032) (SHOWTIME.SHOW.BITMAP 21034 . 21491) (SHOWTIME.WRITEBM 21493 + . 22189))))) STOP diff --git a/lispusers/SHOWTIME.LCOM b/lispusers/SHOWTIME.LCOM index 7847488cc..ccdab5176 100644 Binary files a/lispusers/SHOWTIME.LCOM and b/lispusers/SHOWTIME.LCOM differ diff --git a/lispusers/UNDIGESTIFY b/lispusers/UNDIGESTIFY index 64d6d31c3..1f49658d7 100644 --- a/lispusers/UNDIGESTIFY +++ b/lispusers/UNDIGESTIFY @@ -1,25 +1,30 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "29-Jul-87 08:47:18" {PHYLUM}LYRIC>UNDIGESTIFY.;2 16839 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS INSTALL-UNDIGESTIFY) +(FILECREATED "24-Sep-2023 14:26:57" {WMEDLEY}UNDIGESTIFY.;3 17040 - previous date%: "16-May-86 10:55:33" {PHYLUM}LYRIC>UNDIGESTIFY.;1) + :EDIT-BY rmk + :CHANGES-TO (VARS UNDIGESTIFYCOMS) + (FNS OPEN-SPACE-IN-FILE) -(* " -Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. + :PREVIOUS-DATE "29-Jul-87 08:47:18" {WMEDLEY}UNDIGESTIFY.;1) + + +(* ; " +Copyright (c) 1986-1987 by Xerox Corporation. ") (PRETTYCOMPRINT UNDIGESTIFYCOMS) -(RPAQQ UNDIGESTIFYCOMS ((INITVARS *DELETE-DIGEST-FLAG* *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* - *DONT-UPDATE-HEADERS-FLAG* SEPARATOR1 SEPARATOR2) - (FNS INSTALL-UNDIGESTIFY LAFITE-DISPLAY LAFITE-TRUNCATE-FILE - LAFITE-UNDIGESTIFY MOVE-TO-EOL OPEN-SPACE-IN-FILE - PARSE-AND-MAYBE-MERGE-HEADER SKIP-EOLS BACKUP-PTR - TEDIT.FIND.NOT.CASELESS) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES {ERIS}SOURCES>LAFITEDECLS)) - (P (INSTALL-UNDIGESTIFY)))) +(RPAQQ UNDIGESTIFYCOMS + ((INITVARS *DELETE-DIGEST-FLAG* *MOVE-TO-FIRST-DIGEST-MESSAGE-FLAG* *DONT-UPDATE-HEADERS-FLAG* + SEPARATOR1 SEPARATOR2) + (FNS INSTALL-UNDIGESTIFY LAFITE-DISPLAY LAFITE-TRUNCATE-FILE LAFITE-UNDIGESTIFY MOVE-TO-EOL + OPEN-SPACE-IN-FILE PARSE-AND-MAYBE-MERGE-HEADER SKIP-EOLS BACKUP-PTR + TEDIT.FIND.NOT.CASELESS) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (FROM library/LAFITE) + LAFITEDECLS)) + (P (INSTALL-UNDIGESTIFY)))) (RPAQ? *DELETE-DIGEST-FLAG* NIL) @@ -249,12 +254,16 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. (GETFILEPTR TEXTSTREAM]) (OPEN-SPACE-IN-FILE - [LAMBDA (FILE POSITION NCHARS) (* SCB%: "25-Mar-86 12:52") - - (* Open a space in file starting at POSITION for length NCHARS by sliding the - rest of the file down.) + [LAMBDA (FILE POSITION NCHARS) (* ; "Edited 24-Sep-2023 14:25 by rmk") + (* SCB%: "25-Mar-86 12:52") + + (* ;; + "Open a space in file starting at POSITION for length NCHARS by sliding the rest of the file down.") - (LET [(TEMP (OPENFILE '{NODIRCORE} 'BOTH] + (* Open a space in file starting at POSITION for length NCHARS by sliding the + rest of the file down.) + + (LET [(TEMP (OPENSTREAM '{NODIRCORE} 'BOTH] (COPYBYTES FILE TEMP POSITION (GETEOFPTR FILE)) (SETFILEPTR FILE (IPLUS POSITION NCHARS)) (SETFILEPTR TEMP 0) @@ -302,13 +311,16 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. (TEDIT.FIND TEXTOBJ TARGETSTRING START# END# WILDCARDS?]) ) (DECLARE%: EVAL@COMPILE DONTCOPY -(FILESLOAD {ERIS}SOURCES>LAFITEDECLS) + +(FILESLOAD (FROM library/LAFITE) + LAFITEDECLS) ) -(INSTALL-UNDIGESTIFY) + +(INSTALL-UNDIGESTIFY) (PUTPROPS UNDIGESTIFY COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1217 16647 (INSTALL-UNDIGESTIFY 1227 . 3240) (LAFITE-DISPLAY 3242 . 3541) ( -LAFITE-TRUNCATE-FILE 3543 . 3954) (LAFITE-UNDIGESTIFY 3956 . 13612) (MOVE-TO-EOL 13614 . 14074) ( -OPEN-SPACE-IN-FILE 14076 . 14578) (PARSE-AND-MAYBE-MERGE-HEADER 14580 . 15800) (SKIP-EOLS 15802 . -16113) (BACKUP-PTR 16115 . 16277) (TEDIT.FIND.NOT.CASELESS 16279 . 16645))))) + (FILEMAP (NIL (1183 16831 (INSTALL-UNDIGESTIFY 1193 . 3206) (LAFITE-DISPLAY 3208 . 3507) ( +LAFITE-TRUNCATE-FILE 3509 . 3920) (LAFITE-UNDIGESTIFY 3922 . 13578) (MOVE-TO-EOL 13580 . 14040) ( +OPEN-SPACE-IN-FILE 14042 . 14762) (PARSE-AND-MAYBE-MERGE-HEADER 14764 . 15984) (SKIP-EOLS 15986 . +16297) (BACKUP-PTR 16299 . 16461) (TEDIT.FIND.NOT.CASELESS 16463 . 16829))))) STOP diff --git a/lispusers/UNDIGESTIFY.LCOM b/lispusers/UNDIGESTIFY.LCOM index 139bcc310..c9b599291 100644 Binary files a/lispusers/UNDIGESTIFY.LCOM and b/lispusers/UNDIGESTIFY.LCOM differ diff --git a/lispusers/bitmapfns b/lispusers/bitmapfns index 62f0a19a2..4b2a8546c 100644 --- a/lispusers/bitmapfns +++ b/lispusers/bitmapfns @@ -1,137 +1,139 @@ -(FILECREATED " 3-Jun-86 14:13:59" {ERIS}LIBRARY>BITMAPFNS.;6 6278 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to: (MACROS RPCHK) - (FNS READPRESS) +(FILECREATED "24-Sep-2023 13:54:45" {WMEDLEY}bitmapfns.;2 5976 - previous date: " 2-Jun-86 22:35:15" {ERIS}LIBRARY>BITMAPFNS.;5) + :EDIT-BY rmk + :CHANGES-TO (FNS READPRESS) -(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.) + :PREVIOUS-DATE " 3-Jun-86 14:13:59" {WMEDLEY}bitmapfns.;1) + + +(* ; " +Copyright (c) 1983-1986 by Xerox Corporation. +") (PRETTYCOMPRINT BITMAPFNSCOMS) (RPAQQ BITMAPFNSCOMS ((FNS READBINARYBITMAP WRITEBINARYBITMAP WRITEBM WRITEBMLST READBMLST READBM READPRESS WINDOWBM) - (DECLARE: DONTCOPY (MACROS RPCHK)))) + (DECLARE%: DONTCOPY (MACROS RPCHK)))) (DEFINEQ (READBINARYBITMAP - [LAMBDA (WIDTH HEIGHT FILE) (* lmm " 4-JAN-83 00:19") - (* reads a bitmap from the output file.) - (PROG ((BM (BITMAPCREATE WIDTH HEIGHT))) - (\BINS (GETSTREAM FILE (QUOTE INPUT)) - (fetch BITMAPBASE of BM) - 0 - (ITIMES (fetch BITMAPRASTERWIDTH of BM) - (fetch BITMAPHEIGHT of BM) - 2)) - (RETURN BM]) + [LAMBDA (WIDTH HEIGHT FILE) (* lmm " 4-JAN-83 00:19") + (* reads a bitmap from the output + file.) + (PROG ((BM (BITMAPCREATE WIDTH HEIGHT))) + (\BINS (GETSTREAM FILE 'INPUT) + (fetch BITMAPBASE of BM) + 0 + (ITIMES (fetch BITMAPRASTERWIDTH of BM) + (fetch BITMAPHEIGHT of BM) + 2)) + (RETURN BM]) (WRITEBINARYBITMAP - [LAMBDA (BITMAP FILE) (* JWogulis "26-Dec-84 15:06") - (\BOUTS FILE [ffetch BITMAPBASE of (SETQ BITMAP (\DTEST BITMAP (QUOTE BITMAP] - 0 - (ITIMES (ffetch BITMAPHEIGHT of BITMAP) - (ffetch BITMAPRASTERWIDTH of BITMAP) - BYTESPERWORD]) + [LAMBDA (BITMAP FILE) (* JWogulis "26-Dec-84 15:06") + (\BOUTS FILE [ffetch BITMAPBASE of (SETQ BITMAP (\DTEST BITMAP 'BITMAP] + 0 + (ITIMES (ffetch BITMAPHEIGHT of BITMAP) + (ffetch BITMAPRASTERWIDTH of BITMAP) + BYTESPERWORD]) (WRITEBM - [LAMBDA (FILE BITMAP) (* lmm " 6-Jun-85 16:46") - [BOUT16 FILE (ffetch BITMAPWIDTH of (SETQ BITMAP (\DTEST BITMAP (QUOTE BITMAP] - (BOUT16 FILE (ffetch BITMAPHEIGHT of BITMAP)) + [LAMBDA (FILE BITMAP) (* lmm " 6-Jun-85 16:46") + [BOUT16 FILE (ffetch BITMAPWIDTH of (SETQ BITMAP (\DTEST BITMAP 'BITMAP] + (BOUT16 FILE (ffetch BITMAPHEIGHT of BITMAP)) (WRITEBINARYBITMAP BITMAP FILE]) (WRITEBMLST - [LAMBDA (FILE LST) (* JWogulis "26-Dec-84 15:06") - (PROG [(F (OPENSTREAM FILE (QUOTE OUTPUT) - (QUOTE NEW] + [LAMBDA (FILE LST) (* JWogulis "26-Dec-84 15:06") + (PROG [(F (OPENSTREAM FILE 'OUTPUT 'NEW] (for I in LST do (WRITEBM F I)) - (CLOSEF F]) + (CLOSEF F]) (READBMLST - [LAMBDA (FILE) (* JWogulis "26-Dec-84 15:08") - (bind (F _(OPENSTREAM FILE (QUOTE INPUT) - (QUOTE OLD))) - until (EOFP F) collect (READBM F) finally (CLOSEF F]) + [LAMBDA (FILE) (* JWogulis "26-Dec-84 15:08") + (bind (F _ (OPENSTREAM FILE 'INPUT 'OLD)) until (EOFP F) collect (READBM F) + finally (CLOSEF F]) (READBM - [LAMBDA (FILE) (* lmm " 6-Jun-85 16:46") - (READBINARYBITMAP (BIN16 FILE) - (BIN16 FILE) - FILE]) + [LAMBDA (FILE) (* lmm " 6-Jun-85 16:46") + (READBINARYBITMAP (BIN16 FILE) + (BIN16 FILE) + FILE]) (READPRESS - [LAMBDA (FILENAME) (* lmm " 2-Jun-86 22:34") - (RESETLST (PROG (WW HT MICAWIDTH MICAHEIGHT BITMAP TOTCOUNT (OFD (GETSTREAM (OPENFILE - FILENAME - (QUOTE INPUT) - (QUOTE OLD)) - (QUOTE INPUT))) - X WIDTH) - (RESETSAVE NIL (LIST (QUOTE CLOSEF) - OFD)) - (RPCHK 256) (* Edotcode) - (SETQ WW (IQUOTIENT (BIN16 OFD) - 16)) (* Width) - (SETQ HT (BIN16 OFD)) (* Height) - (until (SELECTC (SETQ X (BIN16 OFD)) - ((IPLUS 512 3) - (* Edotmode and 3) - (RPCHK 2) (* Edotsize) - (SETQ MICAWIDTH (BIN16 OFD)) - (SETQ MICAHEIGHT (BIN16 OFD)) - NIL) - (1 (* Edotwindow) - (BIN16 OFD) - (SETQ WIDTH (BIN16 OFD)) - (RPCHK 0) - (RPCHK HT) - NIL) - (3 T) - (GO ERROR))) - [\BINS OFD (fetch BITMAPBASE of (SETQ BITMAP (BITMAPCREATE (ITIMES WW 16) - HT))) - 0 - (ITIMES 2 (SETQ TOTCOUNT (ITIMES HT WW] - (RPCHK 0) (* Entity list terminator) - [COND - (NIL (* more checks, not necessary) - (PROGN (RPCHK (IPLUS 65280 238)) (* Nop, setx) - (RPCHK 0) - (RPCHK (IPLUS 65280 239)) (* Nop, sety) - (RPCHK 0) - (RPCHK (IPLUS 65280 252)) (* Nop, show dots) - (RPCHK 0] - (RETURN BITMAP) - ERROR - (ERROR "Sorry, unrecognized PRESS file format. READPRESS isn't very general."]) + [LAMBDA (FILENAME) (* ; "Edited 24-Sep-2023 13:54 by rmk") + (* lmm " 2-Jun-86 22:34") + (RESETLST + (PROG (WW HT MICAWIDTH MICAHEIGHT BITMAP TOTCOUNT (OFD (OPENSTREAM FILENAME 'INPUT + 'OLD)) + X WIDTH) + (RESETSAVE NIL (LIST 'CLOSEF OFD)) + (RPCHK 256) (* Edotcode) + (SETQ WW (IQUOTIENT (BIN16 OFD) + 16)) (* Width) + (SETQ HT (BIN16 OFD)) (* Height) + (until (SELECTC (SETQ X (BIN16 OFD)) + ((IPLUS 512 3) (* Edotmode and 3) + (RPCHK 2) (* Edotsize) + (SETQ MICAWIDTH (BIN16 OFD)) + (SETQ MICAHEIGHT (BIN16 OFD)) + NIL) + (1 (* Edotwindow) + (BIN16 OFD) + (SETQ WIDTH (BIN16 OFD)) + (RPCHK 0) + (RPCHK HT) + NIL) + (3 T) + (GO ERROR))) + [\BINS OFD (fetch BITMAPBASE of (SETQ BITMAP (BITMAPCREATE (ITIMES WW 16) + HT))) + 0 + (ITIMES 2 (SETQ TOTCOUNT (ITIMES HT WW] + (RPCHK 0) (* Entity list terminator) + [COND + (NIL (* more checks, not necessary) + (PROGN (RPCHK (IPLUS 65280 238)) (* Nop, setx) + (RPCHK 0) + (RPCHK (IPLUS 65280 239)) (* Nop, sety) + (RPCHK 0) + (RPCHK (IPLUS 65280 252)) (* Nop, show dots) + (RPCHK 0] + (RETURN BITMAP) + ERROR + (ERROR "Sorry, unrecognized PRESS file format. READPRESS isn't very general.")))]) (WINDOWBM - [LAMBDA (BITMAP POSITION) (* JWogulis "26-Dec-84 15:37") - (IF (AND POSITION (NOT (POSITIONP POSITION))) - THEN (ERROR "NOT A POSITION" POSITION)) - [IF (NOT POSITION) - THEN (SETQ POSITION (GETBOXPOSITION (IPLUS 8 (BITMAPWIDTH BITMAP)) - (IPLUS 8 (BITMAPHEIGHT BITMAP] - (PROG ((WIND (CREATEW (LIST (CAR POSITION) - (CDR POSITION) - (IPLUS 8 (BITMAPWIDTH BITMAP)) - (IPLUS 8 (BITMAPHEIGHT BITMAP))) - NIL 4))) - (BITBLT BITMAP 0 0 WIND) - (RETURN WIND]) + [LAMBDA (BITMAP POSITION) (* JWogulis "26-Dec-84 15:37") + (IF (AND POSITION (NOT (POSITIONP POSITION))) + THEN (ERROR "NOT A POSITION" POSITION)) + [IF (NOT POSITION) + THEN (SETQ POSITION (GETBOXPOSITION (IPLUS 8 (BITMAPWIDTH BITMAP)) + (IPLUS 8 (BITMAPHEIGHT BITMAP] + (PROG ((WIND (CREATEW (LIST (CAR POSITION) + (CDR POSITION) + (IPLUS 8 (BITMAPWIDTH BITMAP)) + (IPLUS 8 (BITMAPHEIGHT BITMAP))) + NIL 4))) + (BITBLT BITMAP 0 0 WIND) + (RETURN WIND]) ) -(DECLARE: DONTCOPY -(DECLARE: EVAL@COMPILE -[PUTPROPS RPCHK MACRO ((N) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS RPCHK MACRO ((N) (OR (EQ (BIN16 OFD) N) - (GO ERROR] + (GO ERROR)))) ) ) (PUTPROPS BITMAPFNS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (564 5993 (READBINARYBITMAP 574 . 1075) (WRITEBINARYBITMAP 1077 . 1437) (WRITEBM 1439 . -1752) (WRITEBMLST 1754 . 2028) (READBMLST 2030 . 2305) (READBM 2307 . 2492) (READPRESS 2494 . 5342) ( -WINDOWBM 5344 . 5991))))) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (589 5676 (READBINARYBITMAP 599 . 1213) (WRITEBINARYBITMAP 1215 . 1585) (WRITEBM 1587 . +1874) (WRITEBMLST 1876 . 2112) (READBMLST 2114 . 2351) (READBM 2353 . 2536) (READPRESS 2538 . 4970) ( +WINDOWBM 4972 . 5674))))) STOP diff --git a/sources/ADIR b/sources/ADIR index 4669db0c5..444d2d8de 100644 --- a/sources/ADIR +++ b/sources/ADIR @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "11-May-2023 21:39:25" {DSK}c>Users>Larry>home>il>MEDLEY>SOURCES>ADIR.;2 65907 +(FILECREATED "14-Sep-2023 23:20:17" {WMEDLEY}ADIR.;30 67297 - :EDIT-BY "lmm" + :EDIT-BY rmk - :CHANGES-TO (FNS OPENFILE) + :CHANGES-TO (FNS \COPYSYS) - :PREVIOUS-DATE "31-Oct-2022 23:50:03" -{DSK}c>Users>Larry>home>il>MEDLEY>SOURCES>ADIR.;1) + :PREVIOUS-DATE "14-Sep-2023 22:56:19" {WMEDLEY}ADIR.;29) (PRETTYCOMPRINT ADIRCOMS) @@ -79,16 +78,18 @@ (\GETFILENAME X RECOG]) (INFILE - [LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:23") - (INPUT (OPENFILE FILE 'INPUT 'OLD]) + [LAMBDA (FILE) (* ; "Edited 14-Sep-2023 22:40 by rmk") + (* rmk%: " 3-OCT-79 14:23") + (INPUT (OPENSTREAM FILE 'INPUT 'OLD]) (INFILEP [LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") (\GETFILENAME FILE 'OLD]) (IOFILE - [LAMBDA (FILE) (* rmk%: " 5-SEP-81 13:54") - (OPENFILE FILE 'BOTH 'OLD]) + [LAMBDA (FILE) (* ; "Edited 14-Sep-2023 22:56 by rmk") + (* rmk%: " 5-SEP-81 13:54") + (OPENSTREAM FILE 'BOTH 'OLD]) (OPENFILE [LAMBDA (FILE ACCESS RECOG PARAMETERS OPTIONAL) (* ; "Edited 11-May-2023 21:05 by lmm") @@ -167,8 +168,9 @@ (RETURN STREAM]) (OUTFILE - [LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:24") - (OUTPUT (OPENFILE FILE 'OUTPUT 'NEW]) + [LAMBDA (FILE) (* ; "Edited 13-Sep-2023 17:59 by rmk") + (* rmk%: " 3-OCT-79 14:24") + (OUTPUT (OPENSTREAM FILE 'OUTPUT 'NEW]) (OUTFILEP [LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") @@ -195,50 +197,69 @@ (fetch (IFPAGE NActivePages) of \InterfacePage]) (\COPYSYS - [LAMBDA (FILE SYSNAME DONTSAVE) (* ; "Edited 31-Oct-2022 23:49 by rmk") + [LAMBDA (FILE SYSNAME DONTSAVE) (* ; "Edited 14-Sep-2023 23:19 by rmk") + (* ; "Edited 3-Jul-2023 19:21 by rmk") + (* ; "Edited 1-Jul-2023 12:34 by rmk") + (* ; "Edited 29-Jun-2023 11:41 by rmk") + (* ; "Edited 31-Oct-2022 23:49 by rmk") (* ; "Edited 16-Mar-2021 19:46 by larry") - (PROG (FULLNAME VAL TFILE THOST) + (PROG (TEMPNAME VAL TARGETFILE TARGETHOST PSEUDOHOSTP) RETRY - (SETQ FILE (PACKFILENAME.STRING 'BODY FILE 'BODY "WORK.SYSOUT" 'BODY \CONNECTED.DIRECTORY)) - (SETQ TFILE (TRUEFILENAME FILE)) - [SELECTQ [SETQ THOST (U-CASE (FILENAMEFIELD TFILE 'HOST] - (DSK [SETQ FULLNAME (PACKFILENAME.STRING 'HOST THOST 'NAME 'tmp 'EXTENSION 'SYSOUT + + + (* ;; "RMK: Get the full target name, including version in particular for DSK, at the outset so we know what the RENAMEFILE will do and we can return that value.") + + (* ;; "We try to make the temp file on the same device, so that the RENAMEFILE (hopefully) won't do a copy. ") + + (* ;; "The reason for all this fooling around is because \FLUSHVM doesn't like version numbers.") + + (* ;; "") + + (* ;; "Perhaps we should also check the value of RENAMEFILE to make sure it succeeded?") + + (SETQ FILE (OUTFILEP (PACKFILENAME.STRING 'BODY FILE 'BODY "WORK.SYSOUT" 'BODY + \CONNECTED.DIRECTORY))) + (SETQ PSEUDOHOSTP (PSEUDOHOSTP FILE)) (* ; + "In order to return the expected name at the end.") + (SETQ TARGETFILE (TRUEFILENAME FILE)) + [SELECTQ [SETQ TARGETHOST (U-CASE (FILENAMEFIELD TARGETFILE 'HOST] + (DSK [SETQ TEMPNAME (PACKFILENAME.STRING 'HOST TARGETHOST 'NAME 'tmp 'EXTENSION + 'SYSOUT 'BODY - (\UFS.RECOGNIZE.FILE TFILE 'NON (\GETDEVICEFROMNAME THOST] - (SETQ VAL (\FLUSHVM FULLNAME)) - (SETQ FULLNAME (RENAMEFILE FULLNAME FILE))) - (UNIX [SETQ FULLNAME (CONCAT "{" THOST "}" (\UFS.RECOGNIZE.FILE TFILE 'NON ( - \GETDEVICEFROMNAME - THOST] + (\UFS.RECOGNIZE.FILE TARGETFILE 'NON (\GETDEVICEFROMNAME + TARGETHOST] + (SETQ VAL (\FLUSHVM TEMPNAME))) + (UNIX [SETQ TEMPNAME (CONCAT "{" TARGETHOST "}" (\UFS.RECOGNIZE.FILE TARGETFILE + 'NON + (\GETDEVICEFROMNAME TARGETHOST] (* ; "\DOFLUSHVM ") - (SETQ VAL (\FLUSHVM FULLNAME)) - (SETQ FULLNAME (RENAMEFILE FULLNAME FILE))) + (SETQ VAL (\FLUSHVM TEMPNAME))) (PROGN (SETQ VAL (\FLUSHVM)) - (LET ((UNIXVAR (UNIX-GETENV "LDEDESTSYSOUT"))) + (LET ((LDEDEST (UNIX-GETENV "LDEDESTSYSOUT"))) (* ; - "\FLSUVM saves image to Unix enviroment var or lisp.virtualmem") - (SETQ FULLNAME (COPYFILE (COND - (UNIXVAR (CONCAT "{DSK}" UNIXVAR)) + "\FLUSHVM saves image to Unix enviroment var or lisp.virtualmem. LDEDEST is assumed to be DSK??") + (SETQ TEMPNAME (COPYFILE (COND + (LDEDEST (CONCAT "{DSK}" LDEDEST)) (T "{DSK}~/lisp.virtualmem")) - FILE + TARGETFILE '((TYPE BINARY] (COND - ((NULL VAL) - - (* ;; "First clause of OR is T when resuming this vmem; second is starting the sysout. Unless \COPYSYS1 itself does a \FLUSHVM, the second never returns T, yes? NIL is normal return (continuing in same image), is error return") - (* ; "Continuing in the current image") + ((NULL VAL) (* ; "Continuing in the current image") + (CL:WHEN TARGETFILE (RENAMEFILE TEMPNAME TARGETFILE)) (\DAYTIME0 \LASTUSERACTION) - (RETURN FULLNAME)) + (RETURN (CL:IF PSEUDOHOSTP + (PSEUDOFILENAME TARGETFILE) + TARGETFILE))) ((AND (SMALLP VAL) (IGREATERP 0 VAL)) (* ;  "Error occurred while making sysout.") (LISPERROR (IMINUS VAL) - FULLNAME) + TEMPNAME) (GO RETRY)) - (T (* ; "Starting sysout") + (T (* ; "Restarting sysout") (\CLEARSYSBUF T) (* ; "Get rid of any spurious typeahead") (\RESETKEYBOARD) (* ; "Enable keyhandler") - (RETURN (LIST FULLNAME]) + (RETURN (LIST (OR FILE TEMPNAME]) (\FLUSHVM [LAMBDA (MAIKO.SYSOUTFILE) (* ; "Edited 16-Mar-2021 10:59 by larry") @@ -1229,14 +1250,14 @@ (ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3175 14373 (DELFILE 3185 . 3346) (FULLNAME 3348 . 3715) (INFILE 3717 . 3865) (INFILEP -3867 . 4002) (IOFILE 4004 . 4144) (OPENFILE 4146 . 4449) (OPENSTREAM 4451 . 8791) (OUTFILE 8793 . 8944 -) (OUTFILEP 8946 . 9082) (RENAMEFILE 9084 . 9390) (SIMPLE.FINDFILE 9392 . 9802) (VMEMSIZE 9804 . 9971) - (\COPYSYS 9973 . 13092) (\FLUSHVM 13094 . 14166) (\LOGOUT0 14168 . 14371)) (14831 36736 ( -UNPACKFILENAME.STRING 14841 . 34115) (\UPF.DIRECTORY 34117 . 36734)) (38264 40936 (UNPACKFILENAME -38274 . 38460) (LASTCHPOS 38462 . 39156) (FILENAMEFIELD 39158 . 39643) (FILENAMEFIELD.STRING 39645 . -40224) (PACKFILENAME 40226 . 40569) (PACKFILENAME.STRING 40571 . 40934)) (55406 56319 ( -FILEDIRCASEARRAY 55416 . 56317)) (56486 63666 (LOGOUT 56496 . 57413) (MAKESYS 57415 . 59044) (SYSOUT -59046 . 60598) (SAVEVM 60600 . 61400) (HERALD 61402 . 61562) (INTERPRET.REM.CM 61564 . 63289) ( -\USEREVENT 63291 . 63664)) (63848 65575 (USERNAME 63858 . 64814) (SETUSERNAME 64816 . 65573))))) + (FILEMAP (NIL (3106 15763 (DELFILE 3116 . 3277) (FULLNAME 3279 . 3646) (INFILE 3648 . 3907) (INFILEP +3909 . 4044) (IOFILE 4046 . 4297) (OPENFILE 4299 . 4602) (OPENSTREAM 4604 . 8944) (OUTFILE 8946 . 9208 +) (OUTFILEP 9210 . 9346) (RENAMEFILE 9348 . 9654) (SIMPLE.FINDFILE 9656 . 10066) (VMEMSIZE 10068 . +10235) (\COPYSYS 10237 . 14482) (\FLUSHVM 14484 . 15556) (\LOGOUT0 15558 . 15761)) (16221 38126 ( +UNPACKFILENAME.STRING 16231 . 35505) (\UPF.DIRECTORY 35507 . 38124)) (39654 42326 (UNPACKFILENAME +39664 . 39850) (LASTCHPOS 39852 . 40546) (FILENAMEFIELD 40548 . 41033) (FILENAMEFIELD.STRING 41035 . +41614) (PACKFILENAME 41616 . 41959) (PACKFILENAME.STRING 41961 . 42324)) (56796 57709 ( +FILEDIRCASEARRAY 56806 . 57707)) (57876 65056 (LOGOUT 57886 . 58803) (MAKESYS 58805 . 60434) (SYSOUT +60436 . 61988) (SAVEVM 61990 . 62790) (HERALD 62792 . 62952) (INTERPRET.REM.CM 62954 . 64679) ( +\USEREVENT 64681 . 65054)) (65238 66965 (USERNAME 65248 . 66204) (SETUSERNAME 66206 . 66963))))) STOP diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM index 3da091708..f77f1d8a7 100644 Binary files a/sources/ADIR.LCOM and b/sources/ADIR.LCOM differ diff --git a/sources/CMLCOMPILE b/sources/CMLCOMPILE index 0ffceec72..9d3854eee 100644 --- a/sources/CMLCOMPILE +++ b/sources/CMLCOMPILE @@ -1,20 +1,48 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED " 2-Jul-90 20:24:02" |{PELE:MV:ENVOS}SOURCES>CMLCOMPILE.;7| 21037 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS COMPILE-FILE-EXPRESSION FAKE-COMPILE-FILE COMPILE-FILE-SCAN-FIRST) +(FILECREATED "24-Sep-2023 14:11:25" {WMEDLEY}CMLCOMPILE.;2 22597 - previous date%: "30-Jun-90 18:55:12" |{PELE:MV:ENVOS}SOURCES>CMLCOMPILE.;6|) + :EDIT-BY rmk + + :CHANGES-TO (FNS COMPILE-IN-CORE) + + :PREVIOUS-DATE " 2-Jul-90 20:24:02" {WMEDLEY}CMLCOMPILE.;1) (* ; " -Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. +Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT CMLCOMPILECOMS) -(RPAQQ CMLCOMPILECOMS ((COMS (FUNCTIONS CL:DISASSEMBLE) (FNS FAKE-COMPILE-FILE INTERLISP-FORMAT-P INTERLISP-NLAMBDA-FUNCTION-P COMPILE-FILE-EXPRESSION COMPILE-FILE-WALK-FUNCTION ARGTYPE.STATE COMPILE.CHECK.ARGTYPE COMPILE.FILE.DEFINEQ COMPILE-FILE-SETF-SYMBOL-FUNCTION COMPILE-FILE-EX/IMPORT COMPILE.FILE.APPLY COMPILE.FILE.RESET COMPILE-IN-CORE) (FNS COMPILE-FILE-SCAN-FIRST) (* ; "This function is support for AR#11185") (VARS ARGTYPE.VARS) (PROP COMPILE-FILE-EXPRESSION DEFINEQ * SETF-SYMBOL-FUNCTION PRETTYCOMPRINT) (FUNCTIONS COMPILE-FILE-DECLARE%:)) (COMS (FNS NEWDEFC) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE NEWDEFC) (QUOTE DEFC))))) (PROP FILETYPE CMLCOMPILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA FAKE-COMPILE-FILE))))) - -(CL:DEFUN CL:DISASSEMBLE (NAME-OR-COMPILED-FUNCTION &KEY LEVEL-P (RADIX 8) (OUTPUT *STANDARD-OUTPUT*) FIRST-BYTE MARKED-PC) (PRINTCODE (if (CCODEP NAME-OR-COMPILED-FUNCTION) then NAME-OR-COMPILED-FUNCTION else (CL:COMPILE NIL (if (CL:SYMBOLP NAME-OR-COMPILED-FUNCTION) then (CL:SYMBOL-FUNCTION NAME-OR-COMPILED-FUNCTION) else NAME-OR-COMPILED-FUNCTION))) LEVEL-P RADIX OUTPUT FIRST-BYTE MARKED-PC)) +(RPAQQ CMLCOMPILECOMS + [(COMS (FUNCTIONS CL:DISASSEMBLE) + (FNS FAKE-COMPILE-FILE INTERLISP-FORMAT-P INTERLISP-NLAMBDA-FUNCTION-P + COMPILE-FILE-EXPRESSION COMPILE-FILE-WALK-FUNCTION ARGTYPE.STATE + COMPILE.CHECK.ARGTYPE COMPILE.FILE.DEFINEQ COMPILE-FILE-SETF-SYMBOL-FUNCTION + COMPILE-FILE-EX/IMPORT COMPILE.FILE.APPLY COMPILE.FILE.RESET COMPILE-IN-CORE) + (FNS COMPILE-FILE-SCAN-FIRST) + (* ; + "This function is support for AR#11185") + (VARS ARGTYPE.VARS) + (PROP COMPILE-FILE-EXPRESSION DEFINEQ * SETF-SYMBOL-FUNCTION PRETTYCOMPRINT) + (FUNCTIONS COMPILE-FILE-DECLARE%:)) + [COMS (FNS NEWDEFC) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'NEWDEFC 'DEFC] + (PROP FILETYPE CMLCOMPILE) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA FAKE-COMPILE-FILE]) + +(CL:DEFUN CL:DISASSEMBLE (NAME-OR-COMPILED-FUNCTION &KEY LEVEL-P (RADIX 8) + (OUTPUT *STANDARD-OUTPUT*) + FIRST-BYTE MARKED-PC) + (PRINTCODE (if (CCODEP NAME-OR-COMPILED-FUNCTION) + then NAME-OR-COMPILED-FUNCTION + else (CL:COMPILE NIL (if (CL:SYMBOLP NAME-OR-COMPILED-FUNCTION) + then (CL:SYMBOL-FUNCTION NAME-OR-COMPILED-FUNCTION) + else NAME-OR-COMPILED-FUNCTION))) + LEVEL-P RADIX OUTPUT FIRST-BYTE MARKED-PC)) (DEFINEQ (FAKE-COMPILE-FILE @@ -132,18 +160,24 @@ Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights r (COMPILE-IN-CORE [LAMBDA (fn-name fn-expr fn-type NOSAVE) (DECLARE (SPECVARS LCFIL LAPFLG STRF SVFLG LSTFIL SPECVARS LOCALVARS DONT-TRANSFER-PUTD)) + (* ; "Edited 24-Sep-2023 14:11 by rmk") (* lmm " 2-Jun-86 22:04") + (* ;; "in-core compiling for functions and forms, without the interview. if X is a list, we assume that we are being called merely to display the lap and machine code. the form is compiled as the definition of FOO but the compiled CODE is thrown away. --- if X is a litatom, then saving, redefining, and printing is controlled by the flags.") + (* in-core compiling for functions and forms, without the interview. - if X is a list, we assume that we are being called merely to display the lap - and machine code. the form is compiled as the definition of FOO but the - compiled :CODE is thrown away. - - if X is a litatom, then saving, redefining, and printing is controlled by the - flags.) + if X is a list, we assume that we are being called merely to display the lap and + machine code. the form is compiled as the definition of FOO but the compiled + :CODE is thrown away. - + if X is a litatom, then saving, redefining, and printing is controlled by the + flags.) (LET ((NOREDEFINE NIL) (PRINTLAP NIL) (DONT-TRANSFER-PUTD T)) + + (* ;; "RMK: Is it really worth saving NULLFILE from one invocation to the next?") + (RESETVARS [(NLAMA NLAMA) (NLAML NLAML) (LAMS LAMS) @@ -155,10 +189,9 @@ Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights r (STREAMP NULLFILE) (OPENP NULLFILE)) NULLFILE) - (T (SETQ NULLFILE (OPENFILE '{NULL} 'OUTPUT] - (RETURN (RESETLST (* RESETLST to provide reset context - for macros under COMPILE1 as - generated e.g. by DECL.) + (T (SETQ NULLFILE (OPENSTREAM '{NULL} 'OUTPUT] + (RETURN (RESETLST (* ; + "RESETLST to provide reset context for macros under COMPILE1 as generated e.g. by DECL.") [PROG ((LCFIL) [LAPFLG (AND PRINTLAP (COND (BYTECOMPFLG T) @@ -186,17 +219,46 @@ Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights r (* ; "This function is support for AR#11185") -(RPAQQ ARGTYPE.VARS ((1 NLAML "NLAMBDA spread") (2 LAMA "LAMBDA nospread") (0 LAMS "LAMBDA spread") (3 NLAMA "NLAMBDA no-spread"))) - -(PUTPROPS DEFINEQ COMPILE-FILE-EXPRESSION COMPILE.FILE.DEFINEQ) - -(PUTPROPS * COMPILE-FILE-EXPRESSION NILL) - -(PUTPROPS SETF-SYMBOL-FUNCTION COMPILE-FILE-EXPRESSION COMPILE-FILE-SETF-SYMBOL-FUNCTION) - -(PUTPROPS PRETTYCOMPRINT COMPILE-FILE-EXPRESSION NILL) - -(CL:DEFUN COMPILE-FILE-DECLARE%: (FORM COMPILED.FILE EVAL@COMPILE DOCOPY DEFER) (CL:DO ((TAIL (CDR FORM) (CDR TAIL))) ((CL:ENDP TAIL)) (CL:IF (CL:SYMBOLP (CAR TAIL)) (CASE (CAR TAIL) ((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL) ((EVAL@LOADWHEN) (CL:POP TAIL)) ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T)) ((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL)) ((EVAL@COMPILEWHEN) (SETQ EVAL@COMPILE (EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((COPY DOCOPY) (SETQ DOCOPY T)) ((DONTCOPY) (SETQ DOCOPY NIL)) ((COPYWHEN) (SETQ DOCOPY (EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((FIRST)) ((NOTFIRST COMPILERVARS)) (CL:OTHERWISE (CL:FORMAT COUTFILE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%%" (CAR TAIL)))) (COND ((EQ (QUOTE DECLARE%:) (CAR (CAR TAIL))) (COMPILE-FILE-DECLARE%: (CAR TAIL) COMPILED.FILE EVAL@COMPILE DOCOPY DEFER)) (T (CL:WHEN EVAL@COMPILE (EVAL (CAR TAIL))) (CL:WHEN DOCOPY (COMPILE-FILE-EXPRESSION (CAR TAIL) COMPILED.FILE EVAL@COMPILE DEFER))))))) +(RPAQQ ARGTYPE.VARS ((1 NLAML "NLAMBDA spread") + (2 LAMA "LAMBDA nospread") + (0 LAMS "LAMBDA spread") + (3 NLAMA "NLAMBDA no-spread"))) + +(PUTPROPS DEFINEQ COMPILE-FILE-EXPRESSION COMPILE.FILE.DEFINEQ) + +(PUTPROPS * COMPILE-FILE-EXPRESSION NILL) + +(PUTPROPS SETF-SYMBOL-FUNCTION COMPILE-FILE-EXPRESSION COMPILE-FILE-SETF-SYMBOL-FUNCTION) + +(PUTPROPS PRETTYCOMPRINT COMPILE-FILE-EXPRESSION NILL) + +(CL:DEFUN COMPILE-FILE-DECLARE%: (FORM COMPILED.FILE EVAL@COMPILE DOCOPY DEFER) + (CL:DO ((TAIL (CDR FORM) + (CDR TAIL))) + ((CL:ENDP TAIL)) + (CL:IF (CL:SYMBOLP (CAR TAIL)) + (CASE (CAR TAIL) + ((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL) + ((EVAL@LOADWHEN) (CL:POP TAIL)) + ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T)) + ((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL)) + ((EVAL@COMPILEWHEN) [SETQ EVAL@COMPILE (EVAL (CAR (SETQ TAIL (CDR TAIL]) + ((COPY DOCOPY) (SETQ DOCOPY T)) + ((DONTCOPY) (SETQ DOCOPY NIL)) + ((COPYWHEN) [SETQ DOCOPY (EVAL (CAR (SETQ TAIL (CDR TAIL]) + ((FIRST) ) + ((NOTFIRST COMPILERVARS) ) + (CL:OTHERWISE (CL:FORMAT COUTFILE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%%" + (CAR TAIL)))) + [COND + ((EQ 'DECLARE%: (CAR (CAR TAIL))) + (COMPILE-FILE-DECLARE%: (CAR TAIL) + COMPILED.FILE EVAL@COMPILE DOCOPY DEFER)) + (T (CL:WHEN EVAL@COMPILE + (EVAL (CAR TAIL))) + (CL:WHEN DOCOPY + (COMPILE-FILE-EXPRESSION (CAR TAIL) + COMPILED.FILE EVAL@COMPILE DEFER))]))) (DEFINEQ (NEWDEFC @@ -228,25 +290,26 @@ Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights r ) (DECLARE%: DONTEVAL@LOAD DOCOPY -(MOVD (QUOTE NEWDEFC) (QUOTE DEFC)) +(MOVD 'NEWDEFC 'DEFC) ) -(PUTPROPS CMLCOMPILE FILETYPE CL:COMPILE-FILE) +(PUTPROPS CMLCOMPILE FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS -(ADDTOVAR NLAMA) +(ADDTOVAR NLAMA ) -(ADDTOVAR NLAML) +(ADDTOVAR NLAML ) -(ADDTOVAR LAMA FAKE-COMPILE-FILE) +(ADDTOVAR LAMA FAKE-COMPILE-FILE) ) (PUTPROPS CMLCOMPILE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1675 16480 (FAKE-COMPILE-FILE 1685 . 5121) (INTERLISP-FORMAT-P 5123 . 5341) ( -INTERLISP-NLAMBDA-FUNCTION-P 5343 . 5577) (COMPILE-FILE-EXPRESSION 5579 . 8929) ( -COMPILE-FILE-WALK-FUNCTION 8931 . 9178) (ARGTYPE.STATE 9180 . 9340) (COMPILE.CHECK.ARGTYPE 9342 . -11334) (COMPILE.FILE.DEFINEQ 11336 . 11829) (COMPILE-FILE-SETF-SYMBOL-FUNCTION 11831 . 12425) ( -COMPILE-FILE-EX/IMPORT 12427 . 12755) (COMPILE.FILE.APPLY 12757 . 13017) (COMPILE.FILE.RESET 13019 . -13880) (COMPILE-IN-CORE 13882 . 16478)) (16481 18210 (COMPILE-FILE-SCAN-FIRST 16491 . 18208)) (19612 -20676 (NEWDEFC 19622 . 20674))))) + (FILEMAP (NIL (1636 2253 (CL:DISASSEMBLE 1636 . 2253)) (2254 17523 (FAKE-COMPILE-FILE 2264 . 5700) ( +INTERLISP-FORMAT-P 5702 . 5920) (INTERLISP-NLAMBDA-FUNCTION-P 5922 . 6156) (COMPILE-FILE-EXPRESSION +6158 . 9508) (COMPILE-FILE-WALK-FUNCTION 9510 . 9757) (ARGTYPE.STATE 9759 . 9919) ( +COMPILE.CHECK.ARGTYPE 9921 . 11913) (COMPILE.FILE.DEFINEQ 11915 . 12408) ( +COMPILE-FILE-SETF-SYMBOL-FUNCTION 12410 . 13004) (COMPILE-FILE-EX/IMPORT 13006 . 13334) ( +COMPILE.FILE.APPLY 13336 . 13596) (COMPILE.FILE.RESET 13598 . 14459) (COMPILE-IN-CORE 14461 . 17521)) +(17524 19253 (COMPILE-FILE-SCAN-FIRST 17534 . 19251)) (19796 21163 (COMPILE-FILE-DECLARE%: 19796 . +21163)) (21164 22228 (NEWDEFC 21174 . 22226))))) STOP diff --git a/sources/CMLCOMPILE.LCOM b/sources/CMLCOMPILE.LCOM index dadd93be8..6e4008f2f 100644 Binary files a/sources/CMLCOMPILE.LCOM and b/sources/CMLCOMPILE.LCOM differ diff --git a/sources/COMPILE b/sources/COMPILE index 07bed40cb..d87ed2bbd 100644 --- a/sources/COMPILE +++ b/sources/COMPILE @@ -1,11 +1,13 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS) -(FILECREATED " 5-Jul-2021 13:46:39"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>COMPILE.;4 77731 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS BCOMPL BCOMPL.BODY) +(FILECREATED "24-Sep-2023 13:59:34" {WMEDLEY}COMPILE.;5 77344 - previous date%: " 5-Jul-2021 09:31:55" -{DSK}kaplan>Local>medley3.5>git-medley>sources>COMPILE.;3) + :EDIT-BY rmk + + :CHANGES-TO (VARS COMPILECOMS) + (FNS COMPSET) + + :PREVIOUS-DATE " 5-Jul-2021 13:46:39" {WMEDLEY}COMPILE.;4) (* ; " @@ -22,7 +24,7 @@ with the terms of said license. [(FNS BCOMPL BCOMPL.BODY PRINT-COMPILE-HEADER RESETOPENFILES BCOMPL1A BCOMPL2 BCOMPL3 BLOCK%: BRECOMPILE BRECOMPILE1 BRECOMPILE2 BRECOMPILE3 BLOCKCOMPILE BLOCKCOMPILE1 COMPSET COMPSETREAD COMPSETY COMPSETF RCOMP3 TCOMPL RECOMPILE RECOMP? COMPILE COMPILE1 COMPILE1A - SHOULD-BE-DWIMIFIED? COMPILE.FILECHECK COMPEM GETCFILE SPECVARS LOCALVARS GLOBALVARS) + SHOULD-BE-DWIMIFIED? COMPEM GETCFILE SPECVARS LOCALVARS GLOBALVARS) (ADDVARS (NOLINKFNS HELP ERRORX ERRORSET EVALV FAULTEVAL INTERRUPT SEARCHPDL MAPDL BREAK1 EDITE EDITL) (LINKFNS) @@ -72,7 +74,7 @@ with the terms of said license. (CL:PROCLAIM '(CL:SPECIAL COMPVARMACROHASH)) (CL:PROCLAIM '(GLOBAL SYSSPECVARS SYSLOCALVARS COMPILE.EXT NOTCOMPILEDFILES CLISPARRAY FILERDTBL DWIMFLG DWIMWAIT LISPXHISTORY] - (COMS (* ; "COMPILEMODE") + (COMS (* ; "COMPILEMODE") (PROP VARTYPE COMPILEMODELST) (FNS COMPILEMODE)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS @@ -1018,26 +1020,19 @@ with the terms of said license. (RETURN (OR TEM BLKNAME]) (COMPSET - (LAMBDA (FILE FLG) (* bvm%: " 2-Aug-86 16:58") - - (* If FILE is not NIL, COMPSET doesn't ask any questions but simply initializes - the output FILE, LCFIL. If FLG is T (AND FILE IS NIL) COMPSET doesn't ask for - an output FILE, but does set up LAPFLG, STRF, SVFLG, and LSTFIL. - - - - - BCOMPL and BRECOMPILE both call COMPSET twice, once with FILE NIL and FLG T, - and once with FILE set to their output FILE. - - - COMPILE calls COMPSET only once, with both arguments NIL.) + [LAMBDA (FILE FLG) (* ; "Edited 24-Sep-2023 13:59 by rmk") + (* bvm%: " 2-Aug-86 16:58") + + (* ;; "If FILE is not NIL, COMPSET doesn't ask any questions but simply initializes the output FILE, LCFIL. If FLG is T (AND FILE IS NIL) COMPSET doesn't ask for an output FILE, but does set up LAPFLG, STRF, SVFLG, and LSTFIL. --- --- BCOMPL and BRECOMPILE both call COMPSET twice, once with FILE NIL and FLG T, and once with FILE set to their output FILE. --- COMPILE calls COMPSET only once, with both arguments NIL.") (PROG (OLDO) (COND (FILE (GO NT))) - (SELECTQ (SETQ FILE (COMPSETREAD '"listing? " COMPSETKEYLST (OR FLG '(S T % -)))) - (S (COND + [SELECTQ [SETQ FILE (COMPSETREAD '"listing? " COMPSETKEYLST (OR FLG '(S T % +] + (S [COND (LAPFLG (PRIN1 '"file: " T) - (SETQ LSTFIL (COMPSETF (COMPSETREAD))))) + (SETQ LSTFIL (COMPSETF (COMPSETREAD] (GO NOCHANGE)) ((ST STF) (SETQ LAPFLG NIL) @@ -1055,34 +1050,33 @@ with the terms of said license. (PRIN1 '"file: " T) (SETQ FILE (COMPSETREAD))) NIL) - (SETQ LSTFIL (COMPSETF FILE))))) - (COND - ((SETQ STRF (COMPSETY (COMPSETREAD '"redefine? "))) - (SETQ SVFLG (COMPSETY (COMPSETREAD '"save exprs? "))))) + (SETQ LSTFIL (COMPSETF FILE] + [COND + ([SETQ STRF (COMPSETY (COMPSETREAD '"redefine? "] + (SETQ SVFLG (COMPSETY (COMPSETREAD '"save exprs? "] NOCHANGE (COND - ((AND LAPFLG (NEQ LSTFIL 'T) - (NOT (OPENP LSTFIL 'OUTPUT))) - (SETQ LSTFIL1 (SETQ LSTFIL (OPENFILE LSTFIL 'OUTPUT 'NEW NIL '((TYPE TEXT))))) - - (* LSTFIL1 is set when the file is opened for this compilation. - in this case it will be closed when the compilation is finished or aborttd.) + ([AND LAPFLG (NEQ LSTFIL 'T) + (NOT (OPENP LSTFIL 'OUTPUT] + [SETQ LSTFIL1 (SETQ LSTFIL (OPENSTREAM LSTFIL 'OUTPUT 'NEW '((TYPE TEXT] + + (* ;; "LSTFIL1 is set when the file is opened for this compilation. in this case it will be closed when the compilation is finished or aborttd.") ) (T (SETQ LSTFIL1 NIL))) (COND - ((AND (NULL FLG) + ([AND (NULL FLG) (COMPSETY (COMPSETREAD '"output file? " NIL '(N % -)))) +] (PRIN1 '"file name: " T) (SETQ FILE (COMPSETREAD))) (T (SETQ FILE NIL))) - NT (COND + NT [COND ((AND (SETQ LCFIL (COMPSETF FILE)) (NEQ LCFIL T)) (SETQ LCFIL (OR (OPENP LCFIL 'OUTPUT) - (OPENSTREAM LCFIL 'OUTPUT 'NEW NIL '((TYPE BINARY))))))) - (RETURN 'DONE)))) + (OPENSTREAM LCFIL 'OUTPUT 'NEW '((TYPE BINARY] + (RETURN 'DONE]) (COMPSETREAD (LAMBDA (MESS KEYLST DEFAULT) (* wt%: "23-AUG-80 01:29") @@ -1309,10 +1303,6 @@ with the terms of said license. FINALLY (RETURN (EQ (CAR FORM) 'CLISP%:]) -(COMPILE.FILECHECK - (LAMBDA (FILE) (* lmm "11-Jul-84 17:27") - (OPENFILE FILE 'INPUT))) - (COMPEM (LAMBDA (X Y ERRORFLG FL) (* wt%: " 7-JUL-78 13:07") @@ -1414,15 +1404,13 @@ with the terms of said license. THEN (SETQ GLOBALVARS (UNION A GLOBALVARS]) ) -(ADDTOVAR NOLINKFNS HELP ERRORX ERRORSET EVALV FAULTEVAL INTERRUPT SEARCHPDL MAPDL BREAK1 EDITE - EDITL) +(ADDTOVAR NOLINKFNS HELP ERRORX ERRORSET EVALV FAULTEVAL INTERRUPT SEARCHPDL MAPDL BREAK1 EDITE EDITL) (ADDTOVAR LINKFNS ) (ADDTOVAR FREEVARS ) -(ADDTOVAR SYSSPECVARS HELPCLOCK LISPXHIST RESETSTATE OLDVALUE UNDOSIDE0 SPECVARS LOCALVARS - GLOBALVARS) +(ADDTOVAR SYSSPECVARS HELPCLOCK LISPXHIST RESETSTATE OLDVALUE UNDOSIDE0 SPECVARS LOCALVARS GLOBALVARS) (ADDTOVAR SYSLOCALVARS ) @@ -1455,16 +1443,16 @@ with the terms of said license. (RPAQ? COMPSETLST '(ST F STF S Y N 1 2 NIL T)) (RPAQ? COMPSETKEYLST '((ST "ore and redefine " KEYLST ("" (F . "orget exprs"))) - (S . "ame as last time") - (F . "ile only") - (T . "o terminal") - (1) - (2) - (Y . "es") - (N . "o"))) + (S . "ame as last time") + (F . "ile only") + (T . "o terminal") + (1) + (2) + (Y . "es") + (N . "o"))) (RPAQ? COMPSETDEFAULTKEYLST '((Y . "es") - (N . "o"))) + (N . "o"))) (RPAQ? BCOMPL.SCRATCH '{CORE}BCOMPL.SCRATCH) @@ -1490,8 +1478,8 @@ with the terms of said license. (DECLARE%: EVAL@COMPILE (PUTPROPS DIGITCHARP MACRO [LAMBDA (CHAR) - (AND (IGEQ CHAR (CHARCODE 0)) - (ILEQ CHAR (CHARCODE 9]) + (AND (IGEQ CHAR (CHARCODE 0)) + (ILEQ CHAR (CHARCODE 9]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -1546,14 +1534,14 @@ with the terms of said license. ) (PUTPROPS COMPILE COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3770 74020 (BCOMPL 3780 . 5430) (BCOMPL.BODY 5432 . 12011) (PRINT-COMPILE-HEADER 12013 - . 13076) (RESETOPENFILES 13078 . 13431) (BCOMPL1A 13433 . 19446) (BCOMPL2 19448 . 26263) (BCOMPL3 -26265 . 27614) (BLOCK%: 27616 . 28248) (BRECOMPILE 28250 . 43239) (BRECOMPILE1 43241 . 49093) ( -BRECOMPILE2 49095 . 49897) (BRECOMPILE3 49899 . 51275) (BLOCKCOMPILE 51277 . 53137) (BLOCKCOMPILE1 -53139 . 58224) (COMPSET 58226 . 60989) (COMPSETREAD 60991 . 62302) (COMPSETY 62304 . 62428) (COMPSETF -62430 . 62596) (RCOMP3 62598 . 64305) (TCOMPL 64307 . 64606) (RECOMPILE 64608 . 64691) (RECOMP? 64693 - . 65153) (COMPILE 65155 . 67144) (COMPILE1 67146 . 67734) (COMPILE1A 67736 . 69383) ( -SHOULD-BE-DWIMIFIED? 69385 . 70074) (COMPILE.FILECHECK 70076 . 70222) (COMPEM 70224 . 70948) (GETCFILE - 70950 . 72681) (SPECVARS 72683 . 73238) (LOCALVARS 73240 . 73814) (GLOBALVARS 73816 . 74018)) (76481 -77430 (COMPILEMODE 76491 . 77428))))) + (FILEMAP (NIL (3708 73744 (BCOMPL 3718 . 5368) (BCOMPL.BODY 5370 . 11949) (PRINT-COMPILE-HEADER 11951 + . 13014) (RESETOPENFILES 13016 . 13369) (BCOMPL1A 13371 . 19384) (BCOMPL2 19386 . 26201) (BCOMPL3 +26203 . 27552) (BLOCK%: 27554 . 28186) (BRECOMPILE 28188 . 43177) (BRECOMPILE1 43179 . 49031) ( +BRECOMPILE2 49033 . 49835) (BRECOMPILE3 49837 . 51213) (BLOCKCOMPILE 51215 . 53075) (BLOCKCOMPILE1 +53077 . 58162) (COMPSET 58164 . 60861) (COMPSETREAD 60863 . 62174) (COMPSETY 62176 . 62300) (COMPSETF +62302 . 62468) (RCOMP3 62470 . 64177) (TCOMPL 64179 . 64478) (RECOMPILE 64480 . 64563) (RECOMP? 64565 + . 65025) (COMPILE 65027 . 67016) (COMPILE1 67018 . 67606) (COMPILE1A 67608 . 69255) ( +SHOULD-BE-DWIMIFIED? 69257 . 69946) (COMPEM 69948 . 70672) (GETCFILE 70674 . 72405) (SPECVARS 72407 . +72962) (LOCALVARS 72964 . 73538) (GLOBALVARS 73540 . 73742)) (76094 77043 (COMPILEMODE 76104 . 77041)) +))) STOP diff --git a/sources/COMPILE.LCOM b/sources/COMPILE.LCOM index b8258da8d..7bcb18ddf 100644 Binary files a/sources/COMPILE.LCOM and b/sources/COMPILE.LCOM differ diff --git a/sources/HARDCOPY b/sources/HARDCOPY index 09eaff6ea..de950709b 100644 --- a/sources/HARDCOPY +++ b/sources/HARDCOPY @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "22-Jun-2023 17:31:38" {WMEDLEY}HARDCOPY.;11 104907 +(FILECREATED "24-Sep-2023 15:25:20" {WMEDLEY}HARDCOPY.;13 105614 :EDIT-BY rmk - :CHANGES-TO (FNS MakeMenuOfPrinters) + :CHANGES-TO (FNS CONVERT.FILE.TO.TYPE.FOR.PRINTER) - :PREVIOUS-DATE " 3-Mar-2023 23:49:09" {WMEDLEY}HARDCOPY.;10) + :PREVIOUS-DATE "14-Sep-2023 22:58:42" {WMEDLEY}HARDCOPY.;12) (* ; " @@ -365,8 +365,31 @@ Copyright (c) 1984-1993, 1999, 2018, 2021-2022 by Venue & Xerox Corporation. ) (CONVERT.FILE.TO.TYPE.FOR.PRINTER -(LAMBDA (FILE FILETYPE PRINTERTYPE HEADING PRINTOPTIONS) (* ; "Edited 29-Dec-88 15:39 by jds") (* ;; "Convert FILE to the kind of hardcopy file (Interpress, Press, 4045HQ, etc) appropriate to PRINTERTYPE.") (SETQ FILETYPE (OR FILETYPE (QUOTE TEXT))) (PROG ((SCRATCH (CLOSEF (OPENFILE (PRINTER.SCRATCH.FILE FILE PRINTERTYPE) (QUOTE OUTPUT) (QUOTE NEW))))) (* ; "Doing the open & close gets us a guaranteed version number, so that all files are truly unique.") (APPLY* (OR (LISTGET (PRINTERPROP PRINTERTYPE (QUOTE CONVERSION)) FILETYPE) (for CANPRINT in (PRINTERPROP PRINTERTYPE (QUOTE CANPRINT)) bind CONVERTER when (SETQ CONVERTER (LISTGET (PRINTFILEPROP CANPRINT (QUOTE CONVERSION)) FILETYPE)) do (RETURN CONVERTER)) (ERROR (CONCAT "Can't convert a " FILETYPE " for a " PRINTERTYPE " printer") (FULLNAME FILE))) FILE SCRATCH (LISTGET PRINTOPTIONS (QUOTE FONTS)) HEADING NIL PRINTOPTIONS) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (SCRATCH) (CLOSEF? SCRATCH) (DELFILE SCRATCH))) SCRATCH)) (RETURN SCRATCH))) -) + [LAMBDA (FILE FILETYPE PRINTERTYPE HEADING PRINTOPTIONS) (* ; "Edited 24-Sep-2023 15:25 by rmk") + (* ; "Edited 14-Sep-2023 22:58 by rmk") + (* ; "Edited 29-Dec-88 15:39 by jds") + + (* ;; "Convert FILE to the kind of hardcopy file (Interpress, Press, 4045HQ, etc) appropriate to PRINTERTYPE.") + + (SETQ FILETYPE (OR FILETYPE 'TEXT)) + (PROG [(SCRATCH (CLOSEF (OPENSTREAM (PRINTER.SCRATCH.FILE FILE PRINTERTYPE) + 'OUTPUT + 'NEW] (* ; + "Doing the open & close gets us a guaranteed version number, so that all files are truly unique.") + (APPLY* (OR (LISTGET (PRINTERPROP PRINTERTYPE 'CONVERSION) + FILETYPE) + (for CANPRINT in (PRINTERPROP PRINTERTYPE 'CANPRINT) bind CONVERTER + when (SETQ CONVERTER (LISTGET (PRINTFILEPROP CANPRINT 'CONVERSION) + FILETYPE)) do (RETURN CONVERTER)) + (ERROR (CONCAT "Can't convert a " FILETYPE " for a " PRINTERTYPE " printer") + (FULLNAME FILE))) + FILE SCRATCH (LISTGET PRINTOPTIONS 'FONTS) + HEADING NIL PRINTOPTIONS) + (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SCRATCH) + (CLOSEF? SCRATCH) + (DELFILE SCRATCH] + SCRATCH)) + (RETURN SCRATCH]) (EMPRESS (LAMBDA (FILE %#COPIES HOST HEADING %#SIDES PRINTOPTIONS) (* ; "Edited 26-Aug-87 14:17 by Snow") (SEND.FILE.TO.PRINTER FILE HOST (NCONC (COND (HEADING (LIST (QUOTE HEADING) HEADING))) (COND (%#COPIES (LIST (QUOTE %#COPIES) %#COPIES))) (COND (%#SIDES (LIST (QUOTE %#SIDES) %#SIDES))) PRINTOPTIONS))) @@ -1102,40 +1125,40 @@ Copyright (c) 1984-1993, 1999, 2018, 2021-2022 by Venue & Xerox Corporation. (PUTPROPS HARDCOPY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1999 2018 2021 2022)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (6322 11088 (HARDCOPY.SOMEHOW 6332 . 7690) (HARDCOPYIMAGEW 7692 . 7844) ( -HARDCOPYIMAGEW.TOFILE 7846 . 8154) (HARDCOPYIMAGEW.TOPRINTER 8156 . 9403) (HARDCOPYREGION.TOFILE 9405 - . 9703) (HARDCOPYREGION.TOPRINTER 9705 . 10327) (COPY.WINDOW.TO.BITMAP 10329 . 11086)) (11160 22017 ( -MakeMenuOfPrinters 11170 . 12702) (PRINTERS.WHENSELECTEDFN 12704 . 14446) (MakeMenuOfImageTypes 14448 - . 14966) (GetNewPrinterFromUser 14968 . 15396) (PopUpWindowAndGetAtom 15398 . 16783) ( -PopUpWindowAndGetList 16785 . 18351) (NewPrinter 18353 . 19301) (GetPrinterName 19303 . 19583) ( -GetImageFile 19585 . 21872) (FetchDefaultPrinter 21874 . 22015)) (22052 22590 ( -ExtensionForPrintFileType 22062 . 22255) (PRINTFILETYPE.FROM.EXTENSION 22257 . 22588)) (22645 39029 ( -DEFAULTPRINTER 22655 . 22815) (CAN.PRINT.DIRECTLY 22817 . 22973) (CONVERT.FILE.TO.TYPE.FOR.PRINTER -22975 . 24019) (EMPRESS 24021 . 24334) (HARDCOPYW 24336 . 27296) (LISTFILES1 27298 . 27471) ( -PRINTER.BITMAPFILE 27473 . 27720) (PRINTER.BITMAPSCALE 27722 . 27987) (PRINTER.SCRATCH.FILE 27989 . -28112) (PRINTERPROP 28114 . 28297) (PRINTERSTATUS 28299 . 28488) (PRINTERTYPE 28490 . 30799) ( -PRINTERNAME 30801 . 31103) (PRINTFILEPROP 31105 . 31296) (PRINTFILETYPE 31298 . 33242) ( -\EXPECTED.FILE.TYPE 33244 . 34026) (SEND.FILE.TO.PRINTER 34028 . 39027)) (39030 44012 (PRINTERDEVICE -39040 . 44010)) (44847 53086 (TEXTTOIMAGEFILE 44857 . 47047) (COPY.TEXT.TO.IMAGE 47049 . 53084)) ( -53087 54222 (\BLTSHADE.GENERICPRINTER 53097 . 54220)) (54350 73102 (MAKEHARDCOPYSTREAM 54360 . 55364) -(UNMAKEHARDCOPYSTREAM 55366 . 56050) (HARDCOPYSTREAMTYPE 56052 . 56331) (\CHARWIDTH.HDCPYDISPLAY 56333 - . 56764) (\DSPFONT.HDCPYDISPLAY 56766 . 58171) (\DSPRIGHTMARGIN.HDCPYDISPLAY 58173 . 58750) ( -\DSPXPOSITION.HDCPYDISPLAY 58752 . 59013) (\DSPYPOSITION.HDCPYDISPLAY 59015 . 59276) ( -\STRINGWIDTH.HDCPYDISPLAY 59278 . 59785) (\STRINGWIDTH.HCPYDISPLAYAUX 59787 . 62119) (\HDCPYBLTCHAR -62121 . 64656) (\HDCPYDISPLAY.FIX.XPOS 64658 . 65078) (\HDCPYDISPLAY.FIX.YPOS 65080 . 65500) ( -\HDCPYDISPLAYINIT 65502 . 66279) (\HDCPYDSPPRINTCHAR 66281 . 68441) (\SLOWHDCPYBLTCHAR 68443 . 71946) -(\CHANGECHARSET.HDCPYDISPLAY 71948 . 73100)) (73603 73744 (\MICASTOPTS 73603 . 73744)) (73915 104212 ( -MAKEHARDCOPYMODESTREAM 73925 . 75834) (UNMAKEHARDCOPYMODESTREAM 75836 . 76914) (\BLTSHADE.HCPYMODE -76916 . 77363) (\BITBLT.HCPYMODE 77365 . 77987) (\BRUSHCONVERT.HCPYMODE 77989 . 78226) ( -\CHANGECHARSET.HCPYMODE 78228 . 79995) (\DASHINGCONVERT.HCPYMODE 79997 . 80260) (\CHARWIDTH.HCPYMODE -80262 . 80549) (\DRAWLINE.HCPYMODE 80551 . 80863) (\DRAWCURVE.HCPYMODE 80865 . 81294) ( -\DRAWCIRCLE.HCPYMODE 81296 . 81691) (\DRAWELLIPSE.HCPYMODE 81693 . 82205) (\DSPFONT.HCPYMODE 82207 . -83363) (\DSPLEFTMARGIN.HCPYMODE 83365 . 83949) (\DSPLINEFEED.HCPYMODE 83951 . 84361) ( -\DSPRIGHTMARGIN.HCPYMODE 84363 . 84992) (\DSPSPACEFACTOR.HCPYMODE 84994 . 85515) ( -\DSPXPOSITION.HCPYMODE 85517 . 86098) (\DSPYPOSITION.HCPYMODE 86100 . 86505) (\MOVETO.HCPYMODE 86507 - . 86659) (\FONTCREATE.HCPYMODE.PRESS 86661 . 87673) (\CREATECHARSET.HCPYMODE.PRESS 87675 . 88646) ( -\FONTCREATE.HCPYMODE.INTERPRESS 88648 . 89682) (\CREATECHARSET.HCPYMODE.INTERPRESS 89684 . 90672) ( -\STRINGWIDTH.HCPYMODE 90674 . 91108) (\HCPYMODEBLTCHAR 91110 . 94079) (\HCPYMODEDISPLAYINIT 94081 . -97012) (\HCPYMODEDSPPRINTCHAR 97014 . 99195) (\SLOWHCPYMODEBLTCHAR 99197 . 102711) (\SFFixY.HCPYMODE -102713 . 104210))))) + (FILEMAP (NIL (6336 11102 (HARDCOPY.SOMEHOW 6346 . 7704) (HARDCOPYIMAGEW 7706 . 7858) ( +HARDCOPYIMAGEW.TOFILE 7860 . 8168) (HARDCOPYIMAGEW.TOPRINTER 8170 . 9417) (HARDCOPYREGION.TOFILE 9419 + . 9717) (HARDCOPYREGION.TOPRINTER 9719 . 10341) (COPY.WINDOW.TO.BITMAP 10343 . 11100)) (11174 22031 ( +MakeMenuOfPrinters 11184 . 12716) (PRINTERS.WHENSELECTEDFN 12718 . 14460) (MakeMenuOfImageTypes 14462 + . 14980) (GetNewPrinterFromUser 14982 . 15410) (PopUpWindowAndGetAtom 15412 . 16797) ( +PopUpWindowAndGetList 16799 . 18365) (NewPrinter 18367 . 19315) (GetPrinterName 19317 . 19597) ( +GetImageFile 19599 . 21886) (FetchDefaultPrinter 21888 . 22029)) (22066 22604 ( +ExtensionForPrintFileType 22076 . 22269) (PRINTFILETYPE.FROM.EXTENSION 22271 . 22602)) (22659 39736 ( +DEFAULTPRINTER 22669 . 22829) (CAN.PRINT.DIRECTLY 22831 . 22987) (CONVERT.FILE.TO.TYPE.FOR.PRINTER +22989 . 24726) (EMPRESS 24728 . 25041) (HARDCOPYW 25043 . 28003) (LISTFILES1 28005 . 28178) ( +PRINTER.BITMAPFILE 28180 . 28427) (PRINTER.BITMAPSCALE 28429 . 28694) (PRINTER.SCRATCH.FILE 28696 . +28819) (PRINTERPROP 28821 . 29004) (PRINTERSTATUS 29006 . 29195) (PRINTERTYPE 29197 . 31506) ( +PRINTERNAME 31508 . 31810) (PRINTFILEPROP 31812 . 32003) (PRINTFILETYPE 32005 . 33949) ( +\EXPECTED.FILE.TYPE 33951 . 34733) (SEND.FILE.TO.PRINTER 34735 . 39734)) (39737 44719 (PRINTERDEVICE +39747 . 44717)) (45554 53793 (TEXTTOIMAGEFILE 45564 . 47754) (COPY.TEXT.TO.IMAGE 47756 . 53791)) ( +53794 54929 (\BLTSHADE.GENERICPRINTER 53804 . 54927)) (55057 73809 (MAKEHARDCOPYSTREAM 55067 . 56071) +(UNMAKEHARDCOPYSTREAM 56073 . 56757) (HARDCOPYSTREAMTYPE 56759 . 57038) (\CHARWIDTH.HDCPYDISPLAY 57040 + . 57471) (\DSPFONT.HDCPYDISPLAY 57473 . 58878) (\DSPRIGHTMARGIN.HDCPYDISPLAY 58880 . 59457) ( +\DSPXPOSITION.HDCPYDISPLAY 59459 . 59720) (\DSPYPOSITION.HDCPYDISPLAY 59722 . 59983) ( +\STRINGWIDTH.HDCPYDISPLAY 59985 . 60492) (\STRINGWIDTH.HCPYDISPLAYAUX 60494 . 62826) (\HDCPYBLTCHAR +62828 . 65363) (\HDCPYDISPLAY.FIX.XPOS 65365 . 65785) (\HDCPYDISPLAY.FIX.YPOS 65787 . 66207) ( +\HDCPYDISPLAYINIT 66209 . 66986) (\HDCPYDSPPRINTCHAR 66988 . 69148) (\SLOWHDCPYBLTCHAR 69150 . 72653) +(\CHANGECHARSET.HDCPYDISPLAY 72655 . 73807)) (74310 74451 (\MICASTOPTS 74310 . 74451)) (74622 104919 ( +MAKEHARDCOPYMODESTREAM 74632 . 76541) (UNMAKEHARDCOPYMODESTREAM 76543 . 77621) (\BLTSHADE.HCPYMODE +77623 . 78070) (\BITBLT.HCPYMODE 78072 . 78694) (\BRUSHCONVERT.HCPYMODE 78696 . 78933) ( +\CHANGECHARSET.HCPYMODE 78935 . 80702) (\DASHINGCONVERT.HCPYMODE 80704 . 80967) (\CHARWIDTH.HCPYMODE +80969 . 81256) (\DRAWLINE.HCPYMODE 81258 . 81570) (\DRAWCURVE.HCPYMODE 81572 . 82001) ( +\DRAWCIRCLE.HCPYMODE 82003 . 82398) (\DRAWELLIPSE.HCPYMODE 82400 . 82912) (\DSPFONT.HCPYMODE 82914 . +84070) (\DSPLEFTMARGIN.HCPYMODE 84072 . 84656) (\DSPLINEFEED.HCPYMODE 84658 . 85068) ( +\DSPRIGHTMARGIN.HCPYMODE 85070 . 85699) (\DSPSPACEFACTOR.HCPYMODE 85701 . 86222) ( +\DSPXPOSITION.HCPYMODE 86224 . 86805) (\DSPYPOSITION.HCPYMODE 86807 . 87212) (\MOVETO.HCPYMODE 87214 + . 87366) (\FONTCREATE.HCPYMODE.PRESS 87368 . 88380) (\CREATECHARSET.HCPYMODE.PRESS 88382 . 89353) ( +\FONTCREATE.HCPYMODE.INTERPRESS 89355 . 90389) (\CREATECHARSET.HCPYMODE.INTERPRESS 90391 . 91379) ( +\STRINGWIDTH.HCPYMODE 91381 . 91815) (\HCPYMODEBLTCHAR 91817 . 94786) (\HCPYMODEDISPLAYINIT 94788 . +97719) (\HCPYMODEDSPPRINTCHAR 97721 . 99902) (\SLOWHCPYMODEBLTCHAR 99904 . 103418) (\SFFixY.HCPYMODE +103420 . 104917))))) STOP diff --git a/sources/HARDCOPY.LCOM b/sources/HARDCOPY.LCOM index ace4369d8..b77be8b81 100644 Binary files a/sources/HARDCOPY.LCOM and b/sources/HARDCOPY.LCOM differ diff --git a/sources/PRINTFN b/sources/PRINTFN index e46718577..c64455f83 100644 --- a/sources/PRINTFN +++ b/sources/PRINTFN @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "19-Jun-2022 00:02:19"  -{DSK}kaplan>Local>medley3.5>working-medley>sources>PRINTFN.;34 13484 +(FILECREATED "14-Sep-2023 22:53:09" {WMEDLEY}PRINTFN.;35 13520 - :CHANGES-TO (FNS PFCOPYBYTES) + :EDIT-BY rmk - :PREVIOUS-DATE "15-Mar-2022 00:20:04" -{DSK}kaplan>Local>medley3.5>working-medley>sources>PRINTFN.;33) + :CHANGES-TO (FNS PF) + + :PREVIOUS-DATE "19-Jun-2022 00:02:19" {WMEDLEY}PRINTFN.;34) (* ; " @@ -31,50 +31,51 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation. (DEFINEQ (PF - [NLAMBDA FN (* ; "Edited 4-Apr-2018 11:13 by rmk:") + [NLAMBDA FN (* ; "Edited 14-Sep-2023 22:52 by rmk") + (* ; "Edited 4-Apr-2018 11:13 by rmk:") - (* ;; "RMK; Fixed to skip compiled files, also to use FUNCTIONS as well as FNS. That might not help, if FUNCTIONS are not included in the filemap.") + (* ;; "RMK; Fixed to skip compiled files, also to use FUNCTIONS as well as FNS. That might not help, if FUNCTIONS are not included in the filemap.") - (* ;; "Print from files known to masterscope database before looking at whereis database. Note, however, that it also prefers the masterscope database to incore files") + (* ;; "Print from files known to masterscope database before looking at whereis database. Note, however, that it also prefers the masterscope database to incore files") - (* ;; "If FN is NIL, prints the function named by LASTWORD") + (* ;; "If FN is NIL, prints the function named by LASTWORD") - (* ;; "If FN is a list, then extra args are interpreted as:") + (* ;; "If FN is a list, then extra args are interpreted as:") - (* ;; " OUTPUT FILE") + (* ;; " OUTPUT FILE") - (* ;; "...") + (* ;; "...") (RESETLST (PROG (OUT OTHERARGS IFILES) - (SETQ FN (NLAMBDA.ARGS FN)) (* ; "Grab the args as a list") + (SETQ FN (NLAMBDA.ARGS FN)) (* ; "Grab the args as a list") [COND - ((LISTP FN) (* ; - "If it's a list, take the first element as the function name.") + ((LISTP FN) (* ; + "If it's a list, take the first element as the function name.") (SETQ OTHERARGS (CDR FN)) (SETQ FN (CAR FN] (COND - (FN (* ; "FN name specified; use it.") + (FN (* ; "FN name specified; use it.") (SETQ LASTWORD FN)) - (T (* ; "Not specified, use LASTWORD") + (T (* ; "Not specified, use LASTWORD") (SETQ FN LASTWORD))) [SETQ IFILES (OR (CAR OTHERARGS) (APPEND (WHEREIS FN 'FNS T) (WHEREIS FN 'FUNCTIONS T] [RESETSAVE (OUTPUT (COND - ((CADR OTHERARGS) (* ; - "An output file was specified; if not open for output, open it.") + ((CADR OTHERARGS) (* ; + "An output file was specified; if not open for output, open it.") (OR (OPENP (CADR OTHERARGS) 'OUTPUT) (WINDOWP (CADR OTHERARGS)) - (PROGN [RESETSAVE (SETQ OUT (OPENFILE (CADR OTHERARGS) + (PROGN [RESETSAVE (SETQ OUT (OPENSTREAM (CADR OTHERARGS) 'OUTPUT)) '(PROGN (CLOSEF? OLDVALUE] OUT))) - (T (* ; "otherwise, use primary output.") - T] (* ; "skip compiled files") + (T (* ; "otherwise, use primary output.") + T] (* ; "skip compiled files") (FOR FILE INSIDE IFILES UNLESS (MEMB (FILENAMEFIELD FILE 'EXTENSION) - *COMPILED-EXTENSIONS*) + *COMPILED-EXTENSIONS*) DO (PRINTFN FN FILE))))]) (PF* @@ -288,6 +289,6 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation. ) (PUTPROPS PRINTFN COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1999 2018 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1115 11618 (PF 1125 . 3820) (PF* 3822 . 4116) (PRINTFN 4118 . 4688) (PRINTFNDEF 4690 . -5873) (FINDFNDEF 5875 . 7247) (PFCOPYBYTES 7249 . 11368) (DISPLAYP 11370 . 11616))))) + (FILEMAP (NIL (1044 11654 (PF 1054 . 3856) (PF* 3858 . 4152) (PRINTFN 4154 . 4724) (PRINTFNDEF 4726 . +5909) (FINDFNDEF 5911 . 7283) (PFCOPYBYTES 7285 . 11404) (DISPLAYP 11406 . 11652))))) STOP diff --git a/sources/PRINTFN.LCOM b/sources/PRINTFN.LCOM index 50686fc3e..cde90dd38 100644 Binary files a/sources/PRINTFN.LCOM and b/sources/PRINTFN.LCOM differ