(FILECREATED " 3-APR-82 14:05:27" <BLISP>DCODEFOR10.;47 17747
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 (1980 3354 (NTHCHARCODE 1992 . 2956) (\EOFP 2960 . 3137) (ASSIGNDATATYPE 3141 . 3351)) (
3479 4725 (8BITFILEP 3491 . 3658) (INFILE 3662 . 3827) (OUTFILE 3831 . 4020) (OPENFILE 4024 . 4722)) (
4880 7029 (GETOFD 4892 . 5122) (AIN 5126 . 5988) (AOUT 5992 . 7026)) (7519 7806 (NEWARRAYSIZE 7531 .
7803)) (7927 9555 (\CODEARRAY 7939 . 8295) (\BYTELT 8299 . 8578) (\BYTESETA 8582 . 9305) (\FIXCODENUM
9309 . 9552)) (9589 9865 (POINTERARRAY 9601 . 9862)) (9867 10465 (ELT0 9879 . 10029) (SETA0 10033 .
10192) (ADD1A 10196 . 10462)) (12630 14180 (ARRAYREFC 12642 . 13387) (ARRAYSTOREC 13391 . 14177)) (
14217 14852 (WORDARRAY 14229 . 14562) (FIXPARRAY 14566 . 14849)) (15176 15792 (UNIQUE# 15188 . 15789))
(15945 17624 (READBITMAP 15957 . 16156) (PRINTBITMAP 16160 . 16650) (CREATEPOSITION 16654 . 16705) (
CREATEREGION 16709 . 16768) (CURSORCREATE 16772 . 16829) (PRINTCURSOR 16833 . 17621)))))
STOP