(FILECREATED " 3-APR-82 14:05:27" <BLISP>DCODEFOR10.;47 17096
changes to: PRINTBITMAP READBITMAP PRINTCURSOR
previous date: " 1-APR-82 23:02:49" <BLISP>DCODEFOR10.;46)
(PRETTYCOMPRINT DCODEFOR10COMS)
(RPAQQ DCODEFOR10COMS ((FNS NTHCHARCODE \EOFP ASSIGNDATATYPE)
(COMS (* I/O)
(ADDVARS (8BITEXTS))
[DECLARE: FIRST (P (MOVD? (QUOTE OPENFILE)
(QUOTE 10OPENFILE]
(FNS 8BITFILEP INFILE OUTFILE OPENFILE)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (SELECTQ (SYSTEMTYPE)
(D (SHOULDNT))
NIL)
(PRIN1 "relinking world..." T)
(RELINK (QUOTE WORLD))
(TERPRI T)))
(FNS GETOFD AIN AOUT)
(DECLARE: EVAL@COMPILE DONTCOPY (PROP (MACRO DMACRO)
\BIN \BOUT IEQ)))
(COMS (* array access)
[VARS (ARRAYTYPHA (LIST (HARRAY 100]
[DECLARE: FIRST (P (MOVD? (QUOTE ARRAYSIZE)
(QUOTE OLDARRAYSIZE]
(FNS NEWARRAYSIZE)
[DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE NEWARRAYSIZE)
(QUOTE ARRAYSIZE]
(COMS (* CODE ARRAYS)
(FNS \CODEARRAY \BYTELT \BYTESETA \FIXCODENUM))
(COMS (* pointer arrays)
(FNS POINTERARRAY)
(FNS ELT0 SETA0 ADD1A)
(DECLARE: EVAL@COMPILE DONTCOPY (PROP (DMACRO MACRO)
* FAMACFNS)
(FNS ARRAYREFC ARRAYSTOREC)))
(COMS (* Integer arrays)
(FNS WORDARRAY FIXPARRAY))
(COMS (* IGETHASH, IPUTHASH)
(DECLARE: EVAL@COMPILE (PROP (MACRO DMACRO)
IGETHASH IPUTHASH))
(FNS UNIQUE#)
(VARS (UNIQUE#ARRAY))
(GLOBALVARS UNIQUE#ARRAY)))
(COMS (* Display compatibility fns)
(FNS READBITMAP PRINTBITMAP CREATEPOSITION CREATEREGION CURSORCREATE
PRINTCURSOR))
(DECLARE: EVAL@COMPILE DONTCOPY (FILES (SYSLOAD)
CJSYS
(SOURCE)
MODARITH))))
(DEFINEQ
(NTHCHARCODE
[LAMBDA (X N FLG RDTBL) (* lmm "10-AUG-81 21:12")
(* DCODEFOR10 VERSION; TURNS EOL INTO CR)
(PROG NIL
[COND
[FLG (RETURN (CHCON1 (NTHCHAR X N FLG RDTBL]
((STRINGP X)
NIL)
[(LITATOM X)
(SETQ X (CDR (VAG (IPLUS (LOC X)
2]
(T (RETURN (CHCON1 (NTHCHAR X N FLG RDTBL]
(RETURN (ASSEMBLE NIL
(CQ (VAG (FIX N)))
(MOVE 7 , 1)
(CQ X)
(FASTCALL UPATM)
(SKIPGE 7)
(ADDI 7 , 1 (4))
(JUMPLE 7 , FALSE)
(CAILE 7 , 0 (4))
(JRST FALSE)
(SUBI 7 , 1)
(IDIVI 7 , 5)
(ADDI 3 , 0 (7))
(IBP 3)
(SOJGE 10Q , * -1)
(LDB 1 , 3)
(CAIN 1 , 37Q)
(* turn EOL into CR)
(MOVEI 1 , 15Q)
(ADDI 1 , ASZ)
(JRST OUT)
FALSE
(CQ NIL)
OUT])
(\EOFP
[LAMBDA (FX) (* lmm "10-AUG-81 21:13")
(* DCODEFOR10 VERSION)
(BIT 8 (JS GTSTS FX NIL NIL 2)])
(ASSIGNDATATYPE
[LAMBDA (NAME DESCRIPTORS SIZE SPECS PTRFIELDS)
(* lmm "10-AUG-81 21:13")
(* DCODEFOR10 VERSION)
NIL])
)
(* I/O)
(ADDTOVAR 8BITEXTS )
(DECLARE: FIRST
(MOVD? (QUOTE OPENFILE)
(QUOTE 10OPENFILE))
)
(DEFINEQ
(8BITFILEP
[LAMBDA (FILE) (* lmm "23-JAN-81 13:45")
(AND 8BITEXTS (FMEMB (FILENAMEFIELD FILE (QUOTE EXTENSION))
8BITEXTS)
T])
(INFILE
[LAMBDA (FILE) (* rmk: " 3-OCT-79 14:23")
(INPUT (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD])
(OUTFILE
[LAMBDA (FILE) (* lmm " 7-NOV-81 14:31")
(PROG1 (OUTPUT (OPENFILE FILE (QUOTE OUTPUT)
(QUOTE NEW)))
(LINELENGTH FILELINELENGTH])
(OPENFILE
[LAMBDA (FILE ACCESS RECOG BYTESIZE MACHINE.DEPENDENT.PARAMETERS)
(* lmm "23-JAN-81 13:24")
(SETQ FILE (10OPENFILE FILE ACCESS RECOG [OR BYTESIZE (SETQ BYTESIZE (COND
((8BITFILEP FILE)
8)
(T 7]
MACHINE.DEPENDENT.PARAMETERS))
[COND
([AND (EQ BYTESIZE 8)
(OR (EQ ACCESS (QUOTE OUTPUT))
(EQ ACCESS (QUOTE APPEND]
(* SET NO CRLF BIT)
(ASSEMBLE NIL
(CQ FILE)
(MOVEI 2 , 0 (1))
(FASTCALL OFSET)
(MOVSI 1 , (LRSH (BIT 2)
22Q))
(IORM 1 , FCHAR (FX]
FILE])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(SELECTQ (SYSTEMTYPE)
(D (SHOULDNT))
NIL)
(PRIN1 "relinking world..." T)
(RELINK (QUOTE WORLD))
(TERPRI T)
)
(DEFINEQ
(GETOFD
[LAMBDA (FILE ACCESS) (* lmm "10-AUG-81 21:14")
(* DCODEFOR10 VERSION)
(COND
((SMALLP FILE)
FILE)
(T (OPNJFN (OR FILE (INPUT))
ACCESS])
(AIN
[LAMBDA (ARRAY INDEX N FILE ATYP)
(* lmm "10-AUG-81 21:14")
(* DCODEFOR10 VERSION)
(PROG ((FF (GETOFD FILE (QUOTE OUTPUT)))
(NBYTES N))
(OR (EQ (GETFILEINFO FF (QUOTE OPENBYTESIZE))
8)
(SHOULDNT))
(JS SIN FF (IPLUS (SELECTQ (OR ATYP (GETHASH ARRAY ARRAYTYPHA))
(CODE (IPLUS (LLSH (IDIFFERENCE 44Q (ITIMES (LOGAND INDEX 3)
10Q))
36Q)
1000000000Q
(LRSH INDEX 2)
3))
(SMALLPOSP (SETQ NBYTES (IPLUS N N))
(IPLUS (LLSH (IDIFFERENCE 44Q
(ITIMES (LOGAND INDEX 1)
20Q))
36Q)
1000000000Q
(LRSH INDEX 1)
2))
(SHOULDNT))
(LOC ARRAY))
(IMINUS NBYTES))])
(AOUT
[LAMBDA (ARRAY INDEX N FILE ATYP)
(* lmm "10-AUG-81 21:14")
(* DCODFOR10 VERSION)
(* INDEX and N are in terms of the array's indexing unit)
(* lmm " 1-OCT-80 09:25")
(PROG ((FF (GETOFD FILE (QUOTE OUTPUT)))
(NBYTES N))
(OR (EQ (GETFILEINFO FF (QUOTE OPENBYTESIZE))
8)
(SHOULDNT))
(JS SOUT FF (IPLUS (SELECTQ (OR ATYP (GETHASH ARRAY ARRAYTYPHA))
(CODE (IPLUS (LLSH (IDIFFERENCE 44Q (ITIMES (LOGAND INDEX 3)
10Q))
36Q)
1000000000Q
(LRSH INDEX 2)
3))
(SMALLPOSP (SETQ NBYTES (IPLUS N N))
(IPLUS (LLSH (IDIFFERENCE 44Q
(ITIMES (LOGAND INDEX 1)
20Q))
36Q)
1000000000Q
(LRSH INDEX 1)
2))
(SHOULDNT))
(LOC ARRAY))
(IMINUS NBYTES)))
ARRAY])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(PUTPROPS \BIN MACRO ((JFN)
(JS BIN JFN NIL NIL 2)))
(PUTPROPS \BOUT MACRO ((JFN BYTE)
(JS BOUT JFN BYTE)))
(PUTPROPS IEQ MACRO ((X Y)
(IEQP X Y)))
(PUTPROPS \BIN DMACRO T)
(PUTPROPS \BOUT DMACRO T)
(PUTPROPS IEQ DMACRO (= . EQ))
)
(* array access)
(RPAQ ARRAYTYPHA (LIST (HARRAY 100)))
(DECLARE: FIRST
(MOVD? (QUOTE ARRAYSIZE)
(QUOTE OLDARRAYSIZE))
)
(DEFINEQ
(NEWARRAYSIZE
[LAMBDA (A) (* lmm "11-AUG-81 23:48")
(SELECTQ (GETHASH A ARRAYTYPHA)
(CODE (UNFOLD (IDIFFERENCE (OLDARRAYSIZE A)
3)
BYTESPERCELL))
(WORD (LLSH (OLDARRAYSIZE A)
1))
(OLDARRAYSIZE A])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD (QUOTE NEWARRAYSIZE)
(QUOTE ARRAYSIZE))
)
(* CODE ARRAYS)
(DEFINEQ
(\CODEARRAY
[LAMBDA (NBYTES NTSIZE) (* lmm "10-AUG-81 21:15")
(* DCODEFOR10 VERSION)
(PROG [(A (ARRAY (IPLUS 3 (FOLDHI NBYTES BYTESPERCELL))
(IPLUS 3 (FOLDHI NBYTES BYTESPERCELL]
(SETA A 1 NBYTES)
(PUTHASH A (QUOTE CODE)
ARRAYTYPHA)
(RETURN A])
(\BYTELT
[LAMBDA (CA LOC) (* lmm "10-AUG-81 21:16")
(* DCODEFOR10 VERSION)
(LOGAND (LRSH (OPENR (IPLUS (LOC CA)
(LRSH LOC 2)
3))
(IDIFFERENCE 28 (ITIMES (LOGAND LOC 3)
8)))
255])
(\BYTESETA
[LAMBDA (CA LOC NEWVAL) (* DECLARATIONS:
(BLOCKRECORD DUMMY ((B0 BITS 8)
(B1 BITS 8)
(B2 BITS 8)
(B3 BITS 8)
(D BITS 4))))
(* lmm "10-AUG-81 21:16")
(* DCODEFOR10 VERSION)
(* lmm "18-MAY-80 12:37")
(SETQ CA (VAG (IPLUS (LOC CA)
(LRSH LOC 2)
3)))
(SELECTQ (LOGAND LOC 3)
(0 (replace B0 of CA with NEWVAL))
(1 (replace B1 of CA with NEWVAL))
(2 (replace B2 of CA with NEWVAL))
(3 (replace B3 of CA with NEWVAL))
NIL])
(\FIXCODENUM
[LAMBDA (A POS VAL) (* lmm "10-AUG-81 21:16")
(* DCODEFOR10 VERSION)
(\BYTESETA A (SUB1 POS)
(LRSH VAL 8))
(\BYTESETA A POS VAL)
VAL])
)
(* pointer arrays)
(DEFINEQ
(POINTERARRAY
[LAMBDA (N INIT) (* lmm "10-AUG-81 21:18")
(* DCODEFOR10 VERSION)
(PROG ((A (ARRAY N NIL INIT)))
(PUTHASH A (QUOTE POINTER)
ARRAYTYPHA)
(RETURN A])
)
(DEFINEQ
(ELT0
[LAMBDA (A N) (* lmm "13-JUL-80 11:54")
(* FOR MAXC)
(ELT A (ADD1 N])
(SETA0
[LAMBDA (A N V) (* lmm "13-JUL-80 11:54")
(* FOR MAXC)
(SETA A (ADD1 N)
V])
(ADD1A
[LAMBDA (A N) (* lmm "13-JUL-80 11:51")
(* On the Alto, assumes A is 0-origin.)
(* FOR MAXC ONLY)
(SETA A (SETQ N (ADD1 N))
(ADD1 (ELT A N])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(RPAQQ FAMACFNS (FASTELT FASTELTN FASTSETA FASTSETAN FASTELTW FASTSETAW ADD1ELT))
(PUTPROPS FASTELT DMACRO T)
(PUTPROPS FASTELTN DMACRO T)
(PUTPROPS FASTSETA DMACRO T)
(PUTPROPS FASTSETAN DMACRO T)
(PUTPROPS FASTELTW DMACRO T)
(PUTPROPS FASTSETAW DMACRO T)
(PUTPROPS ADD1ELT DMACRO T)
(PUTPROPS FASTELT MACRO [X (SUBPAIR (QUOTE (EXP . DISP))
(ARRAYREFC X)
(QUOTE (ASSEMBLE NIL (CQ EXP)
(HRRZ 1 , DISP (1])
(PUTPROPS FASTELTN MACRO [X (SUBPAIR (QUOTE (EXP . DISP))
(ARRAYREFC X)
(QUOTE (LOC (ASSEMBLE NIL
(CQ EXP)
(MOVE 1 , DISP (1])
(PUTPROPS FASTSETA MACRO [X (ARRAYSTOREC X (QUOTE ((CQ V)
(PUSH PP , 1)))
(QUOTE ((POP PP , 3)))
[QUOTE ((HRRM 3 , 0 (2]
(QUOTE ((PUSH PP , 2)
(MOVE 1 , 3)
(ACCALL 3 , ' SETA0])
(PUTPROPS FASTSETAN MACRO [X (ARRAYSTOREC X (QUOTE ((CQ (VAG V))
(PUSHN)))
(QUOTE ((POPN 3)))
[QUOTE ((MOVEM 3 , 0 (2]
(QUOTE ((PUSH PP , 1)
(MOVE 1 , 3)
(CQ (LOC (AC)))
(ACCALL 3 , ' SETA0])
(PUTPROPS FASTELTW MACRO [(A N)
(LOC (ASSEMBLE NIL
(CQ A)
(CQ2 (VAG (FIX N)))
(MOVE 3 , = 242001000002Q)
(TRNE 2 , 1)
(MOVE 3 , = 42001000002Q)
(LSH 2 , -1)
(ADDI 1 , 0 (2))
(LDB 1 , 3])
(PUTPROPS FASTSETAW MACRO [LAMBDA (A N V)
(SELECTQ (LOGAND N 1)
(0 (ASSEMBLE NIL
(CQ (VAG (IPLUS (LOC A)
(LRSH N 1)
2)))
(CQ2 (VAG (FIX V)))
(DPB 2 , = 242001000000Q)))
(1 (ASSEMBLE NIL
(CQ (VAG (IPLUS (LOC A)
(LRSH N 1)
2)))
(CQ2 (VAG (FIX V)))
(DPB 2 , = 42001000000Q)))
(SHOULDNT))
V])
(PUTPROPS ADD1ELT MACRO [X (ARRAYSTOREC X NIL NIL [QUOTE ((AOS 0 (2]
(QUOTE ((ACCALL 2 , ' ADD1A])
(DEFINEQ
(ARRAYREFC
[LAMBDA (X) (* lpd " 9-SEP-78 10:17")
(* X is a list (ARR INDEX --). Returns (EXP . DISP), where EXP is an expression that computes the address of element
INDEX of array ARR (0-origin) and DISP is the displacement for a load or store instruction.)
(PROG ((A (CAR X))
(N (CADR X))
U)
[COND
((SETQ U (NOT (LITATOM N)))
(SETQ N (LIST (QUOTE VAG)
N]
(RETURN (CONS [SUBPAIR (QUOTE (A N))
(LIST A N)
(COND
[(LITATOM A)
(QUOTE (ASSEMBLE NIL (CQ N)
(VAR (ADD 1 , A]
(T (QUOTE (VAG (IPLUS (LOC A)
(LOC N]
(COND
(U 2)
(T (IDIFFERENCE 2 (LOC 0])
(ARRAYSTOREC
[LAMBDA (X PREL POSTL OPL SETL)
(* lmm "14-JUL-80 08:52")
(PROG [(N (COND
[(LITATOM (CADR X))
(QUOTE ((CQ N)
(SUBI 1 , ASZ -2]
(T (QUOTE ((CQ (VAG (IPLUS N 2]
[SETQ N (COND
[(LITATOM (CAR X))
(APPEND N (QUOTE ((VAR (HRRZ 2 , A]
(T (APPEND (QUOTE ((CQ A)
(PUSH PP , 1)))
N
(QUOTE ((POP PP , 2]
(RETURN (SUBPAIR (QUOTE (A N V))
X
(APPEND (QUOTE (ASSEMBLE NIL))
PREL N POSTL (QUOTE ((CAIL 1 , 2)
(CAML 1 , 0 (2))
(JUMPA BAD)
(ADD 2 , 1)))
OPL
(QUOTE ((JUMPA GOOD)
BAD
(PUSH PP , 2)
(ADDI 1 , ASZ -2)))
SETL
(QUOTE (GOOD])
)
)
(* Integer arrays)
(DEFINEQ
(WORDARRAY
[LAMBDA (N) (* lmm "30-JUL-81 20:46")
(SELECTQ (SYSTEMTYPE)
((ALTO D)
(ARRAY N (QUOTE SMALLPOSP)
0 0))
(PROG ((A (ARRAY (SETQ N (LRSH (ADD1 N)
1))
N)))
(PUTHASH A (QUOTE WORD)
ARRAYTYPHA)
(RETURN A])
(FIXPARRAY
[LAMBDA (N) (* lmm "30-JUL-81 20:46")
(SELECTQ (SYSTEMTYPE)
((ALTO D)
(ARRAY N (QUOTE FIXP)
0 0))
(PROG ((A (ARRAY N N)))
(PUTHASH A (QUOTE FIXP)
ARRAYTYPHA)
(RETURN A])
)
(* IGETHASH, IPUTHASH)
(DECLARE: EVAL@COMPILE
(PUTPROPS IGETHASH MACRO ((X ARR)
(GETHASH (UNIQUE# X)
ARR)))
(PUTPROPS IPUTHASH MACRO ((ITEM VAL HARRAY)
(PUTHASH (UNIQUE# ITEM)
VAL HARRAY)))
(PUTPROPS IGETHASH DMACRO T)
(PUTPROPS IPUTHASH DMACRO T)
)
(DEFINEQ
(UNIQUE#
[LAMBDA (X) (* edited: "17-JUL-80 07:54")
(* So that can hash on large number -- returns an integer suchthat if (IEQP X Y) then (AND (EQ
(UNIQUE# X) (UNIQUE# Y)) (IEQP X (UNIQUE# X))))
(OR (SMALLP X)
(PROG ((N (LOGAND X 511))
LL L1)
(SETQ LL (SETQ L1 (FASTELT (OR UNIQUE#ARRAY (SETQ UNIQUE#ARRAY (POINTERARRAY 512)))
N)))
LP (COND
((NULL LL)
(FASTSETA UNIQUE#ARRAY N (CONS X L1))
(RETURN X))
((IEQP X (CAR LL))
(RETURN (CAR LL)))
(T (SETQ LL (CDR LL))
(GO LP])
)
(RPAQQ UNIQUE#ARRAY NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS UNIQUE#ARRAY)
)
(* Display compatibility fns)
(DEFINEQ
(READBITMAP
[LAMBDA (WIDTH HEIGHT BPI) (* rmk: " 3-APR-82 13:59")
(COND
(WIDTH (APPEND (LIST WIDTH HEIGHT BPI)
(READ)))
(T (READ])
(PRINTBITMAP
[LAMBDA (BITMAP) (* rmk: " 3-APR-82 13:58")
(DECLARE (LOCALVARS . T))
(PROG [(BM (COND
((LITATOM BITMAP)
(EVALV BITMAP))
(T BITMAP]
(COND
([AND (FIXP (CAR (LISTP BM)))
[FIXP (CAR (LISTP (CDR BM]
(OR [STRINGP (CAR (LISTP (CDDR BM]
(FIXP (CAR (LISTP (CDDR BM]
(PRINT BM))
(T (printout T "********* " BITMAP " IS NOT A BITMAP REPRESENTATION." T])
(CREATEPOSITION
[LAMBDA NIL
(CONS 0 0])
(CREATEREGION
[LAMBDA NIL
(LIST 0 0 1000 1000])
(CURSORCREATE
[LAMBDA (BM X Y)
(LIST BM X Y])
(PRINTCURSOR
[LAMBDA (VAR) (* rmk: " 3-APR-82 14:05")
(PROG (BM (VALUE (EVALV VAR)))
(COND
((AND (LISTP (CAR VALUE))
[AND [FIXP (CAR (LISTP (SETQ BM (CAR VALUE]
[FIXP (CAR (LISTP (CDR BM]
(OR [STRINGP (CAR (LISTP (CDDR BM]
(FIXP (CAR (LISTP (CDDR BM]
(FIXP (CADR VALUE))
(FIXP (CADDR VALUE))
(NULL (CDDDR VALUE))) (* for ABC, form of cursor is
(BITMAP X Y))
(printout NIL "(RPAQ " VAR , (CONS (QUOTE CURSORCREATE)
(CONS (QUOTE (READBITMAP))
(CDR VALUE)))
")" T)
(PRINTBITMAP (CAR VALUE)))
(T (printout T "********* " VAR " IS NOT A CURSOR REPRESENTATION." T])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (SYSLOAD)
CJSYS
(SOURCE)
MODARITH)
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1926 3251 (NTHCHARCODE 1936 . 2865) (\EOFP 2867 . 3041) (ASSIGNDATATYPE 3043 . 3249)) (
3364 4570 (8BITFILEP 3376 . 3537) (INFILE 3541 . 3701) (OUTFILE 3703 . 3888) (OPENFILE 3892 . 4568)) (
4716 6796 (GETOFD 4726 . 4949) (AIN 4951 . 5787) (AOUT 5789 . 6794)) (7257 7533 (NEWARRAYSIZE 7267 .
7531)) (7644 9223 (\CODEARRAY 7654 . 8002) (\BYTELT 8004 . 8275) (\BYTESETA 8277 . 8982) (\FIXCODENUM
8984 . 9221)) (9251 9518 (POINTERARRAY 9261 . 9516)) (9519 10098 (ELT0 9531 . 9676) (SETA0 9680 . 9833
) (ADD1A 9837 . 10096)) (12185 13678 (ARRAYREFC 12197 . 12916) (ARRAYSTOREC 12920 . 13676)) (13708
14318 (WORDARRAY 13718 . 14040) (FIXPARRAY 14042 . 14316)) (14622 15216 (UNIQUE# 14634 . 15214)) (
15357 16981 (READBITMAP 15367 . 15561) (PRINTBITMAP 15563 . 16040) (CREATEPOSITION 16044 . 16091) (
CREATEREGION 16095 . 16150) (CURSORCREATE 16152 . 16207) (PRINTCURSOR 16209 . 16979)))))
STOP
TOP