(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 4-Dec-88 18:15:30" {QV}<IDL>KOTO>BLAS.;4 20760
changes to%: (VARS BLASCOMS) (MACROS MUL2 BLAS.CHECKARRAY) (FNS BLAS.ADD BLAS.ARRAYBLT BLAS.ARRAYFILL BLAS.ASUM BLAS.AXPY BLAS.DOTPROD BLAS.MAX BLAS.ROT BLAS.SCAL BLAS.SUM BLAS.SWAP \FLOATARRAYBLT \FLOATARRAYFILL)
previous date%: "17-Jun-86 10:46:22" {QV}<IDL>KOTO>BLAS.;1)
(* "
Copyright (c) 1986, 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT BLASCOMS)
(RPAQQ BLASCOMS ((DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES CMLARRAY-SUPPORT UNBOXEDOPS)) (FNS BLAS.ADD BLAS.ARRAYBLT BLAS.ARRAYFILL BLAS.ASUM BLAS.AXPY BLAS.COPY BLAS.DOTPROD BLAS.MAX BLAS.NRM2 BLAS.ROT BLAS.ROTGMACRO BLAS.SCAL BLAS.SUM BLAS.SWAP \FLOATARRAYBLT \FLOATARRAYFILL) (MACROS BLAS.CHECKARRAY BLAS.CHECKOFFSET BLAS.CHECKSIZE BLAS.CHECKSKIP BLAS.COMPUTECNT BLAS.ROTG MUL2 MUL32) (INITRECORDS PILOTBBT) (DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS PILOTBBT)) (DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T))))
(DECLARE%: DONTCOPY DOEVAL@COMPILE
(FILESLOAD CMLARRAY-SUPPORT UNBOXEDOPS)
)
(DEFINEQ
(BLAS.ADD
(LAMBDA (SCALAR X XOFFSET XSKIP CNT) (* ; "Edited 4-Dec-88 18:10 by jop") (* ;;; "Implements vector plus SCALAR. X must be a FLOAT array. SCALAR must be a FLOATP. CNT defaults to largest vector commensurate with XOFFSET and XSKIP. Returns X") (SETQ SCALAR (FLOAT SCALAR)) (BLAS.CHECKARRAY X) (LET ((XSIZE (CL:ARRAY-TOTAL-SIZE X))) (* ;;; "Arg checking") (BLAS.CHECKOFFSET XOFFSET XSIZE) (BLAS.CHECKSKIP XSKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT XSIZE XOFFSET XSKIP)) elseif (ILESSP CNT 0) then (HELP "Cnt less than zero" CNT)) (BLAS.CHECKSIZE XSIZE XOFFSET XSKIP CNT) (* ;;; "Compute the result") (bind (XBASE ← (%%ARRAY-BASE X)) (FSCALAR ← SCALAR) for I from 1 to CNT as XINDEX from (MUL2 XOFFSET) by (MUL2 XSKIP) declare (TYPE FLOATP FSCALAR) do (\PUTBASEFLOATP XBASE XINDEX (FPLUS FSCALAR (\GETBASEFLOATP XBASE XINDEX)))) X))
)
(BLAS.ARRAYBLT
(LAMBDA (SOURCE SOURCEOFFSET SOURCESKIP DEST DESTOFFSET DESTSKIP CNT) (* jop%: " 4-Jun-86 14:17") (* * Blt CNT entries of SOURCE starting at SOURCEOFFSET with skip SOURCESKIP to DEST starting at DESTOFFSET with skip DESTSKIP. SOURCE and DEST must be FLOATP ARRAYS. If DEST is NIL will create a vector of the appropriate size. SOURCEOFFSET and DESTOFFSET default to zero. SOURCESKIP and DESTSKIP default to one. CNT defaults to the max count commensurate with SOURCEOFFSET and SOURCESKIP. Returns DEST) (BLAS.CHECKARRAY SOURCE) (LET ((SOURCESIZE (CL:ARRAY-TOTAL-SIZE SOURCE)) DESTSIZE) (* * Start arg checking) (BLAS.CHECKOFFSET SOURCEOFFSET SOURCESIZE) (BLAS.CHECKSKIP SOURCESKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT SOURCESIZE SOURCEOFFSET SOURCESKIP)) elseif (ILESSP CNT 0) then (HELP "CNT less than zero" CNT)) (BLAS.CHECKSIZE SOURCESIZE SOURCEOFFSET SOURCESKIP CNT) (if (NULL DEST) then (SETQ DEST (CL:MAKE-ARRAY CNT (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY DEST)) (SETQ DESTSIZE (CL:ARRAY-TOTAL-SIZE DEST)) (BLAS.CHECKOFFSET DESTOFFSET DESTSIZE) (BLAS.CHECKSKIP DESTSKIP) (BLAS.CHECKSIZE DESTSIZE DESTOFFSET DESTSKIP CNT) (* * Do the BLT) (LET ((SOURCEBASE (%%ARRAY-BASE SOURCE)) (DESTBASE (%%ARRAY-BASE DEST)) (LIMIT 2048)) (* Check that offsets and skips are less than (MAX.SMALLP / 32)) (if (NOT (ILESSP SOURCEOFFSET LIMIT)) then (SETQ SOURCEBASE (\ADDBASE SOURCEBASE (MUL2 SOURCEOFFSET))) (SETQ SOURCEOFFSET 0)) (if (NOT (ILESSP DESTOFFSET LIMIT)) then (SETQ DESTBASE (\ADDBASE DESTBASE (MUL2 DESTOFFSET))) (SETQ DESTOFFSET 0)) (if (NOT (AND (ILESSP SOURCESKIP LIMIT) (ILESSP DESTSKIP LIMIT))) then (HELP "Skip larger than limit")) (\FLOATARRAYBLT SOURCEBASE SOURCEOFFSET SOURCESKIP DESTBASE DESTOFFSET DESTSKIP CNT)) DEST))
)
(BLAS.ARRAYFILL
(LAMBDA (SOURCEFLOATP DEST DESTOFFSET DESTSKIP CNT) (* jop%: " 4-Jun-86 14:20") (* * Fill the float array DEST starting at DESTOFFSET with skip DESTSKIP with the FLOATP SOURCEFLOATP. DESTOFFSET defaults to zero. DESTSKIP defaults to one. CNT defaults to the max count commensurate with DESTOFFSET and DESTSKIP. Returns DEST) (SETQ SOURCEFLOATP (FLOAT SOURCEFLOATP)) (LET (DESTSIZE) (* * Arg checking) (if (AND CNT (NULL DEST)) then (SETQ DEST (CL:MAKE-ARRAY CNT (QUOTE :ELEMENT-TYPE) (QUOTE FLOAT))) else (BLAS.CHECKARRAY DEST)) (SETQ DESTSIZE (CL:ARRAY-TOTAL-SIZE DEST)) (BLAS.CHECKOFFSET DESTOFFSET DESTSIZE) (BLAS.CHECKSKIP DESTSKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT DESTSIZE DESTOFFSET DESTSKIP)) elseif (ILESSP CNT 0) then (HELP "CNT less than zero" CNT)) (BLAS.CHECKSIZE DESTSIZE DESTOFFSET DESTSKIP CNT) (* * Do the Fill) (LET ((DESTBASE (%%ARRAY-BASE DEST)) (LIMIT 2048)) (* Check that offsets and skips are less than (MAX.SMALLP / 32)) (if (NOT (ILESSP DESTOFFSET LIMIT)) then (SETQ DESTBASE (\ADDBASE DESTBASE (MUL2 DESTOFFSET))) (SETQ DESTOFFSET 0)) (if (NOT (ILESSP DESTSKIP LIMIT)) then (HELP "Skip larger than limit" DESTSKIP)) (\FLOATARRAYFILL SOURCEFLOATP DESTBASE DESTOFFSET DESTSKIP CNT)) DEST))
)
(BLAS.ASUM
(LAMBDA (X XOFFSET XSKIP CNT) (* jop%: " 4-Jun-86 14:22") (* * Implements BLAS sum of magnitudes. X must be a FLOAT array. CNT defaults to largest vector commensurate with XOFFSET and XSKIP. Returns X) (BLAS.CHECKARRAY X) (LET ((XSIZE (CL:ARRAY-TOTAL-SIZE X))) (* * Start arg checking) (BLAS.CHECKOFFSET XOFFSET XSIZE) (BLAS.CHECKSKIP XSKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT XSIZE XOFFSET XSKIP)) elseif (ILESSP CNT 0) then (HELP "CNT less than zero" CNT)) (BLAS.CHECKSIZE XSIZE XOFFSET XSKIP CNT) (* *) (bind (XBASE ← (%%ARRAY-BASE X)) (RESULT ← 0.0) for I from 0 to CNT as INDEX from (MUL2 XOFFSET) by (MUL2 XSKIP) declare (TYPE FLOATP RESULT) do (SETQ RESULT (FPLUS RESULT (UFABS (\GETBASEFLOATP XBASE INDEX)))) finally (RETURN RESULT))))
)
(BLAS.AXPY
(LAMBDA (SCALAR X XOFFSET XSKIP Y YOFFSET YSKIP CNT) (* jop%: " 4-Jun-86 14:23") (* * Implements BLAS elementary vector operation (Y = SCALAR * X + Y) X and Y must be FLOAT arrays. SCALAR must be a FLOATP. CNT defaults to largest vector commensurate with XOFFSET and XSKIP. Returns Y) (SETQ SCALAR (FLOAT SCALAR)) (BLAS.CHECKARRAY X) (BLAS.CHECKARRAY Y) (LET ((XSIZE (CL:ARRAY-TOTAL-SIZE X)) (YSIZE (CL:ARRAY-TOTAL-SIZE Y))) (* * Start arg checking) (BLAS.CHECKOFFSET XOFFSET XSIZE) (BLAS.CHECKSKIP XSKIP) (BLAS.CHECKOFFSET YOFFSET YSIZE) (BLAS.CHECKSKIP YSKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT XSIZE XOFFSET XSKIP)) elseif (ILESSP CNT 0) then (HELP "CNT less than zero" CNT)) (BLAS.CHECKSIZE XSIZE XOFFSET XSKIP CNT) (BLAS.CHECKSIZE YSIZE YOFFSET YSKIP CNT) (* *) (bind (XBASE ← (%%ARRAY-BASE X)) (YBASE ← (%%ARRAY-BASE Y)) (FSCALAR ← SCALAR) for I from 1 to CNT as XINDEX from (MUL2 XOFFSET) by (MUL2 XSKIP) as YINDEX from (MUL2 YOFFSET) by (MUL2 YSKIP) declare (TYPE FLOATP FSCALAR) do (\PUTBASEFLOATP YBASE YINDEX (FPLUS (\GETBASEFLOATP YBASE YINDEX) (FTIMES FSCALAR (\GETBASEFLOATP XBASE XINDEX))))) Y))
)
(BLAS.COPY
(LAMBDA (X XOFFSET XSKIP Y YOFFSET YSKIP CNT) (* jop%: " 4-Jun-86 14:24") (* * Implements BLAS array copy. Returns NIL if CNT < 0 else returns Y) (BLAS.ARRAYBLT X XOFFSET XSKIP Y YOFFSET YSKIP CNT))
)
(BLAS.DOTPROD
(LAMBDA (X XOFFSET XSKIP Y YOFFSET YSKIP CNT) (* jop%: " 4-Jun-86 14:25") (* * Implements BLAS dot product. X and Y must be FLOAT arrays. CNT defaults to largest vector commensurate with XOFFSET and XSKIP) (BLAS.CHECKARRAY X) (BLAS.CHECKARRAY Y) (LET ((XSIZE (CL:ARRAY-TOTAL-SIZE X)) (YSIZE (CL:ARRAY-TOTAL-SIZE Y))) (* * Start arg checking) (BLAS.CHECKOFFSET XOFFSET XSIZE) (BLAS.CHECKSKIP XSKIP) (BLAS.CHECKOFFSET YOFFSET YSIZE) (BLAS.CHECKSKIP YSKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT XSIZE XOFFSET XSKIP)) elseif (ILESSP CNT 0) then (HELP "CNT less than zero" CNT)) (BLAS.CHECKSIZE XSIZE XOFFSET XSKIP CNT) (BLAS.CHECKSIZE YSIZE YOFFSET YSKIP CNT) (* * Compute the inner product) (bind (XBASE ← (%%ARRAY-BASE X)) (YBASE ← (%%ARRAY-BASE Y)) (FSUM ← 0.0) for I from 1 to CNT as XINDEX from (MUL2 XOFFSET) by (MUL2 XSKIP) as YINDEX from (MUL2 YOFFSET) by (MUL2 YSKIP) declare (TYPE FLOATP FSUM) do (SETQ FSUM (FPLUS FSUM (FTIMES (\GETBASEFLOATP XBASE XINDEX) (\GETBASEFLOATP YBASE YINDEX)))) finally (RETURN FSUM))))
)
(BLAS.MAX
(LAMBDA (X XOFFSET XSKIP CNT) (* jop%: " 4-Jun-86 14:26") (* * Implements BLAS array max. Returns index of entry with maximum absolute value) (BLAS.CHECKARRAY X) (LET ((XSIZE (CL:ARRAY-TOTAL-SIZE X))) (* * Start arg checking) (BLAS.CHECKOFFSET XOFFSET XSIZE) (BLAS.CHECKSKIP XSKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT XSIZE XOFFSET XSKIP)) elseif (ILESSP CNT 0) then (HELP "CNT less than zero" CNT)) (BLAS.CHECKSIZE XSIZE XOFFSET XSKIP CNT) (* *) (bind (XBASE ← (%%ARRAY-BASE X)) (FMAX ← MIN.FLOAT) (MAXINDEX ← 0) XTEMP for I from 0 to (SUB1 CNT) as XINDEX from (MUL2 XOFFSET) by (MUL2 XSKIP) declare (TYPE FLOATP FMAX XTEMP) do (SETQ XTEMP (UFABS (\GETBASEFLOATP XBASE XINDEX))) (if (UFGREATERP XTEMP FMAX) then (SETQ FMAX XTEMP) (SETQ MAXINDEX I)) finally (RETURN MAXINDEX))))
)
(BLAS.NRM2
(LAMBDA (X XOFFSET XSKIP CNT) (* jop%: " 4-Jun-86 14:26") (* * Implements BLAS euclidean norm. X must be a FLOAT array. CNT defaults to largest vector commensurate with XOFFSET and XSKIP.) (SQRT (BLAS.DOTPROD X XOFFSET XSKIP X XOFFSET XSKIP CNT)))
)
(BLAS.ROT
(LAMBDA (C S X XOFFSET XSKIP Y YOFFSET YSKIP CNT) (* jop%: " 4-Jun-86 14:28") (* * Implements BLAS Givens rotation. X and Y must be FLOAT arrays. CNT defaults to largest vector commensurate with XOFFSET and XSKIP. RETURNS Y) (SETQ C (FLOAT C)) (SETQ S (FLOAT S)) (BLAS.CHECKARRAY X) (BLAS.CHECKARRAY Y) (LET ((XSIZE (CL:ARRAY-TOTAL-SIZE X)) (YSIZE (CL:ARRAY-TOTAL-SIZE Y))) (* * Start arg checking) (BLAS.CHECKOFFSET XOFFSET XSIZE) (BLAS.CHECKSKIP XSKIP) (BLAS.CHECKOFFSET YOFFSET YSIZE) (BLAS.CHECKSKIP YSKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT XSIZE XOFFSET XSKIP)) elseif (ILESSP CNT 0) then (HELP "CNT less than zero" CNT)) (BLAS.CHECKSIZE XSIZE XOFFSET XSKIP CNT) (BLAS.CHECKSIZE YSIZE YOFFSET YSKIP CNT) (* * Do the rotation) (bind (XBASE ← (%%ARRAY-BASE X)) (YBASE ← (%%ARRAY-BASE Y)) (FC ← C) (FS ← S) XTEMP YTEMP for I from 1 to CNT as XINDEX from (MUL2 XOFFSET) by (MUL2 XSKIP) as YINDEX from (MUL2 YOFFSET) by (MUL2 YSKIP) declare (TYPE FLOATP FC FS XTEMP YTEMP) do (SETQ XTEMP (\GETBASEFLOATP XBASE XINDEX)) (SETQ YTEMP (\GETBASEFLOATP YBASE YINDEX)) (\PUTBASEFLOATP XBASE XINDEX (FPLUS (FTIMES FC XTEMP) (FTIMES FS YTEMP))) (\PUTBASEFLOATP YBASE YINDEX (FDIFFERENCE (FTIMES FC YTEMP) (FTIMES FS XTEMP)))) Y))
)
(BLAS.ROTGMACRO
(LAMBDA (ARGS) (* jop%: "26-May-86 15:57") (* *) (LET ((BA (CAR ARGS)) (BB (CADR ARGS)) (BC (CADDR ARGS)) (BS (CADDDR ARGS))) (BQUOTE (LET* ((SIGMA (if (FGREATERP (FABS %, BA) (FABS %, BB)) then (if (FLESSP %, BA 0.0) then -1.0 else 1.0) else (if (FLESSP %, BB 0.0) then -1.0 else 1.0))) (RADIUS (FTIMES SIGMA (SQRT (FTIMES %, BA %, BA) (FTIMES %, BB %, BB))))) (SETQ %, BC (if (NOT (FEQP RADIUS 0.0)) then (FQUOTIENT %, BA RADIUS) else 1.0)) (SETQ %, BS (if (NOT (FEQP RADIUS 0.0)) then (FQUOTIENT %, BB RADIUS) else 0.0)) (if (FEQP %, BC 0.0) then 1.0 elseif (FGREATERP (FABS %, BA) (FABS %, BB)) then %, BS else (FQUOTIENT 1.0 %, BC))))))
)
(BLAS.SCAL
(LAMBDA (SCALAR X XOFFSET XSKIP CNT) (* jop%: " 4-Jun-86 14:29") (* * Implements BLAS vector scaling (X = A * X) %. X must be a FLOAT array. SCALAR must be a FLOATP. CNT defaults to largest vector commensurate with XOFFSET and XSKIP. Returns X) (SETQ SCALAR (FLOAT SCALAR)) (BLAS.CHECKARRAY X) (LET ((XSIZE (CL:ARRAY-TOTAL-SIZE X))) (* * Start arg checking) (BLAS.CHECKOFFSET XOFFSET XSIZE) (BLAS.CHECKSKIP XSKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT XSIZE XOFFSET XSKIP)) elseif (ILESSP CNT 0) then (HELP "Cnt less than zero" CNT)) (BLAS.CHECKSIZE XSIZE XOFFSET XSKIP CNT) (* * Compute the result using array ops) (bind (XBASE ← (%%ARRAY-BASE X)) (FSCALAR ← SCALAR) for I from 1 to CNT as XINDEX from (MUL2 XOFFSET) by (MUL2 XSKIP) declare (TYPE FLOATP FSCALAR) do (\PUTBASEFLOATP XBASE XINDEX (FTIMES FSCALAR (\GETBASEFLOATP XBASE XINDEX)))) X))
)
(BLAS.SUM
(LAMBDA (X XOFFSET XSKIP CNT) (* jop%: " 4-Jun-86 14:30") (* * Implements vector sum reduction. X must be a FLOAT array. CNT defaults to largest vector commensurate with XOFFSET and XSKIP. Returns X) (BLAS.CHECKARRAY X) (LET ((XSIZE (CL:ARRAY-TOTAL-SIZE X))) (* * Arg checking) (BLAS.CHECKOFFSET XOFFSET XSIZE) (BLAS.CHECKSKIP XSKIP) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT XSIZE XOFFSET XSKIP)) elseif (ILESSP CNT 0) then (HELP "Cnt less than zero" CNT)) (BLAS.CHECKSIZE XSIZE XOFFSET XSKIP CNT) (* *) (bind (XBASE ← (%%ARRAY-BASE X)) (RESULT ← 0.0) for I from 0 to CNT as INDEX from (MUL2 XOFFSET) by (MUL2 XSKIP) declare (TYPE FLOATP RESULT) do (SETQ RESULT (FPLUS RESULT (\GETBASEFLOATP XBASE INDEX))) finally (RETURN RESULT))))
)
(BLAS.SWAP
(LAMBDA (X XOFFSET XSKIP Y YOFFSET YSKIP CNT) (* jop%: " 4-Jun-86 14:31") (* * Implements BLAS swap array. X and Y must be FLOAT arrays. Returns Y) (BLAS.CHECKARRAY X) (BLAS.CHECKARRAY Y) (LET ((XSIZE (CL:ARRAY-TOTAL-SIZE X)) (YSIZE (CL:ARRAY-TOTAL-SIZE Y))) (* * Start arg checking) (BLAS.CHECKOFFSET XOFFSET XSIZE) (BLAS.CHECKSKIP XSKIP) (BLAS.CHECKOFFSET YOFFSET YSIZE) (BLAS.CHECKSKIP YSKIP) (* Default CNT) (if (NULL CNT) then (SETQ CNT (BLAS.COMPUTECNT XSIZE XOFFSET XSKIP)) elseif (ILESSP CNT 0) then (HELP "Cnt less than zero" CNT)) (BLAS.CHECKSIZE XSIZE XOFFSET XSKIP CNT) (BLAS.CHECKSIZE YSIZE YOFFSET YSKIP CNT) (* * Now do the swap) (bind (XBASE ← (%%ARRAY-BASE X)) (YBASE ← (%%ARRAY-BASE Y)) XTEMP for I from 1 to CNT as XINDEX from (MUL2 XOFFSET) by (MUL2 XSKIP) as YINDEX from (MUL2 YOFFSET) by (MUL2 YSKIP) declare (TYPE FLOATP XTEMP) do (SETQ XTEMP (\GETBASEFLOATP XBASE XINDEX)) (\PUTBASEFLOATP XBASE XINDEX (\GETBASEFLOATP YBASE YINDEX)) (\PUTBASEFLOATP YBASE YINDEX XTEMP)) Y))
)
(\FLOATARRAYBLT
(LAMBDA (SOURCEBASE SOURCEOFFSET SOURCESKIP DESTBASE DESTOFFSET DESTSKIP CNT) (* ; "Edited 4-Dec-88 18:11 by jop") (* ;;; "Raw version of BLAS.ARRAYBLT. No arg checking or defaults. SOURCEBASE and DESTBASE must point to Float array blocks. Other args as in BLAS.ARRAYBLT Note that the fields of PILOTBBT are no longer than 16 bit words, so DESTOFFSET etc need to be less than 2048 to keep things SMALLP. Returns NIL") (if (IGREATERP CNT 1) then (if (AND (EQ SOURCESKIP 1) (EQ DESTSKIP 1)) then (* ;; "Special case when both source and dest are contiguous") (PROG ((SOURCEPLUSOFFSET (\ADDBASE SOURCEBASE (MUL2 SOURCEOFFSET))) (DESTPLUSOFFSET (\ADDBASE DESTBASE (MUL2 DESTOFFSET)))) (* ;; "Execute the BLT") (\BLT DESTPLUSOFFSET SOURCEPLUSOFFSET (MUL2 CNT))) else (* ;; "General case") (PROG ((GBBT (DEFERREDCONSTANT (create PILOTBBT PBTWIDTH ← 32 PBTDISJOINT ← T)))) (* ;; "Set fields in BLT table") (replace (PILOTBBT PBTSOURCE) of GBBT with SOURCEBASE) (replace (PILOTBBT PBTSOURCEBIT) of GBBT with (MUL32 SOURCEOFFSET)) (replace (PILOTBBT PBTSOURCEBPL) of GBBT with (MUL32 SOURCESKIP)) (replace (PILOTBBT PBTDEST) of GBBT with DESTBASE) (replace (PILOTBBT PBTDESTBIT) of GBBT with (MUL32 DESTOFFSET)) (replace (PILOTBBT PBTDESTBPL) of GBBT with (MUL32 DESTSKIP)) (replace (PILOTBBT PBTHEIGHT) of GBBT with CNT) (* ;; "Execute the BLT") (\PILOTBITBLT GBBT 0)))))
)
(\FLOATARRAYFILL
(LAMBDA (SOURCEFLOATP DESTBASE DESTOFFSET DESTSKIP CNT) (* ; "Edited 4-Dec-88 18:11 by jop") (* ;;; "Fill CNT entries of DESTBASE starting at DESTOFFSET with skip DESTSKIP, with the FLOATP SOURCEFLOATP. No arg checking is attempted. Returns NIL") (if (IGREATERP CNT 0) then (if (EQ DESTSKIP 1) then (* ;; "Special case of contiguous destination") (PROG ((DESTPLUSOFFSET (\ADDBASE DESTBASE (MUL2 DESTOFFSET))) (TWICECNTLESS1 (MUL2 (SUB1 CNT)))) (* ;; "Setup the last entry") (\PUTBASEFLOATP DESTPLUSOFFSET TWICECNTLESS1 SOURCEFLOATP) (* ;; "\BLT operates backwards") (\BLT DESTPLUSOFFSET (\ADDBASE DESTPLUSOFFSET 2) TWICECNTLESS1)) else (* ;; "General case") (PROG ((BITDESTSKIP (MUL32 DESTSKIP)) (GBBT (DEFERREDCONSTANT (create PILOTBBT PBTWIDTH ← 32 PBTDISJOINT ← T)))) (* ;; "Setup the first entry") (\PUTBASEFLOATP DESTBASE (MUL2 DESTOFFSET) SOURCEFLOATP) (* ;; "Set fields in BLT table") (replace (PILOTBBT PBTSOURCE) of GBBT with DESTBASE) (replace (PILOTBBT PBTSOURCEBIT) of GBBT with (MUL32 DESTOFFSET)) (replace (PILOTBBT PBTSOURCEBPL) of GBBT with BITDESTSKIP) (* ;; "Same as source except displaced by one entry") (replace (PILOTBBT PBTDEST) of GBBT with DESTBASE) (replace (PILOTBBT PBTDESTBIT) of GBBT with (MUL32 (IPLUS DESTOFFSET DESTSKIP))) (replace (PILOTBBT PBTDESTBPL) of GBBT with BITDESTSKIP) (* ;; "(SUB1 CNT) since first entry already done") (replace (PILOTBBT PBTHEIGHT) of GBBT with (SUB1 CNT)) (* ;; "Execute the BLT depending on copy on") (\PILOTBITBLT GBBT 0)))))
)
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS BLAS.CHECKARRAY MACRO (OPENLAMBDA (X) (if (NOT (AND (CL:ARRAYP X) (EQ (CL:ARRAY-ELEMENT-TYPE X) (QUOTE CL:SINGLE-FLOAT)))) then (HELP "Must be an array of FLOATP's" X))))
(PUTPROPS BLAS.CHECKOFFSET MACRO (OPENLAMBDA (OFFSET SIZE) (if (NULL OFFSET) then (SETQ OFFSET 0) elseif (NOT (AND (IGEQ OFFSET 0) (ILESSP OFFSET SIZE))) then (HELP "OFFSET out of bounds" OFFSET))))
(PUTPROPS BLAS.CHECKSIZE MACRO (OPENLAMBDA (ARRAYSIZE ARRAYOFFSET ARRAYSKIP CNT) (if (IGEQ (IPLUS ARRAYOFFSET (ITIMES ARRAYSKIP (SUB1 CNT))) ARRAYSIZE) then (HELP "CNT too large" CNT))))
(PUTPROPS BLAS.CHECKSKIP MACRO (OPENLAMBDA (SKIP) (if (NULL SKIP) then (SETQ SKIP 1) elseif (NOT (IGREATERP SKIP 0)) then (HELP "SKIP out of bounds" SKIP))))
(PUTPROPS BLAS.COMPUTECNT MACRO (OPENLAMBDA (ARRAYSIZE ARRAYOFFSET ARRAYSKIP) (if (EQ ARRAYSKIP 1) then (IDIFFERENCE ARRAYSIZE ARRAYOFFSET) else (IQUOTIENT (IDIFFERENCE ARRAYSIZE ARRAYOFFSET) ARRAYSKIP))))
(PUTPROPS BLAS.ROTG MACRO (ARGS (if (NOT (EQLENGTH ARGS 4)) then (ERROR "Macro must have four args" ARGS)) (BLAS.ROTGMACRO ARGS)))
(PUTPROPS MUL2 MACRO ((X) (LLSH X 1)))
(PUTPROPS MUL32 MACRO ((X) (LLSH X 5)))
)
(/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE ((PILOTBBT 0 (BITS . 15)) (PILOTBBT 1 (BITS . 15)) (PILOTBBT 2 (BITS . 15)) (PILOTBBT 3 (SIGNEDBITS . 15)) (PILOTBBT 4 (BITS . 15)) (PILOTBBT 5 (BITS . 15)) (PILOTBBT 6 (BITS . 15)) (PILOTBBT 7 (SIGNEDBITS . 15)) (PILOTBBT 8 (BITS . 15)) (PILOTBBT 9 (BITS . 15)) (PILOTBBT 10 (BITS . 15)) (PILOTBBT 11 (BITS . 15)) (PILOTBBT 12 (BITS . 15)) (PILOTBBT 13 (BITS . 15)) (PILOTBBT 14 (BITS . 15)) (PILOTBBT 15 (BITS . 15)))) (QUOTE 16))
(DECLARE%: DONTCOPY DOEVAL@COMPILE
(DECLARE%: EVAL@COMPILE
(DATATYPE PILOTBBT ((PBTDESTLO WORD) (PBTDESTHI WORD) (PBTDESTBIT WORD) (* Destination bit address) (PBTDESTBPL SIGNEDWORD) (* Destination bits per line -- distance in bits to move between items) (PBTSOURCELO WORD) (PBTSOURCEHI WORD) (PBTSOURCEBIT WORD) (* Source bit address) (PBTSOURCEBPL SIGNEDWORD) (* Source bits per line) (PBTWIDTH WORD) (* Width of an item in bits) (PBTHEIGHT WORD) (* Number of items -- height in scanlines) (PBTFLAGS WORD) (NIL 5 WORD) (* Unused, needed to make 16-alignment))
(BLOCKRECORD PILOTBBT ((NIL 7 WORD) (NIL BITS 4) (* Overlay on PBTSOURCEBPL when PBTUSEGRAY) (PBTGRAYOFFSET BITS 4) (* Offset in gray block where BITBLT should start) (PBTGRAYWIDTHLESSONE BITS 4) (* Width-1 of gray block in words) (PBTGRAYHEIGHTLESSONE BITS 4) (* Height-1 of gray block) (NIL 2 WORD) (* Overlay on PBTFLAGS |...|) (PBTBACKWARD FLAG) (PBTDISJOINT FLAG) (PBTDISJOINTITEMS FLAG) (PBTUSEGRAY FLAG) (PBTSOURCETYPE BITS 1) (PBTOPERATION BITS 2) (NIL BITS 9)))
(ACCESSFNS PILOTBBT ((PBTSOURCE (\VAG2 (fetch PBTSOURCEHI of DATUM) (fetch PBTSOURCELO of DATUM)) (PROGN (replace PBTSOURCEHI of DATUM with (\HILOC NEWVALUE)) (replace PBTSOURCELO of DATUM with (\LOLOC NEWVALUE)))) (PBTDEST (\VAG2 (fetch PBTDESTHI of DATUM) (fetch PBTDESTLO of DATUM)) (PROGN (replace PBTDESTHI of DATUM with (\HILOC NEWVALUE)) (replace PBTDESTLO of DATUM with (\LOLOC NEWVALUE))))))
(SYSTEM))
)
(/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE ((PILOTBBT 0 (BITS . 15)) (PILOTBBT 1 (BITS . 15)) (PILOTBBT 2 (BITS . 15)) (PILOTBBT 3 (SIGNEDBITS . 15)) (PILOTBBT 4 (BITS . 15)) (PILOTBBT 5 (BITS . 15)) (PILOTBBT 6 (BITS . 15)) (PILOTBBT 7 (SIGNEDBITS . 15)) (PILOTBBT 8 (BITS . 15)) (PILOTBBT 9 (BITS . 15)) (PILOTBBT 10 (BITS . 15)) (PILOTBBT 11 (BITS . 15)) (PILOTBBT 12 (BITS . 15)) (PILOTBBT 13 (BITS . 15)) (PILOTBBT 14 (BITS . 15)) (PILOTBBT 15 (BITS . 15)))) (QUOTE 16))
)
(DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS BLAS COPYRIGHT ("Xerox Corporation" 1986 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1142 16784 (BLAS.ADD 1152 . 2013) (BLAS.ARRAYBLT 2015 . 3799) (BLAS.ARRAYFILL 3801 .
5050) (BLAS.ASUM 5052 . 5824) (BLAS.AXPY 5826 . 6965) (BLAS.COPY 6967 . 7182) (BLAS.DOTPROD 7184 .
8234) (BLAS.MAX 8236 . 9041) (BLAS.NRM2 9043 . 9307) (BLAS.ROT 9309 . 10558) (BLAS.ROTGMACRO 10560 .
11223) (BLAS.SCAL 11225 . 12099) (BLAS.SUM 12101 . 12856) (BLAS.SWAP 12858 . 13872) (\FLOATARRAYBLT
13874 . 15264) (\FLOATARRAYFILL 15266 . 16782)))))
STOP