File psl-1983/3-1/windows/windows-9836.sl from the latest check-in


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% WINDOWS-9836.SL - HP9836 Windows Stuff (intended only for HP9836 version)
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        20 January 1983
% Revised:     5 April 1983
%
% 5-Apr-83 Alan Snyder
%  Changes relating to keeping WINDOWS source and binary files in separate
%  directories.  Rename Shared-Screen to Shared-Physical-Screen, for
%  compatibility with other systems.
% 16-Mar-83 Alan Snyder
%  Add font8, LAP support.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(compiletime (load fast-strings fast-int))
(bothtimes (load strings common))

(fluid '(window-file-list window-source-prefix window-binary-prefix))

(if (or (unboundp 'window-source-prefix) (null window-source-prefix))
  (setf window-source-prefix "pw:"))

(if (or (unboundp 'window-binary-prefix) (null window-binary-prefix))
  (setf window-binary-prefix "pwb:"))

(de charsininputbuffer () (if (keyboard-input-available?) 1 0))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Stuff for Building WINDOWS:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de window-fixup-name (s) s)

(de window-load-all ()
  (for (in s window-file-list)
       (do (window-load s))
       ))

(de window-load (s)
  (window-faslin window-binary-prefix s)
  )

(de window-faslin (directory-name module-name)
  (setf module-name (window-fixup-name module-name))
  (setf module-name (string-concat module-name ".b"))
  (let ((object-name (string-concat directory-name module-name)))
    (if (filep object-name)
      (faslin object-name)
      (continuableerror 99
       (bldmsg "Unable to FASLIN %w" object-name)
       (list 'faslin object-name)
       ))))

(setf window-file-list
  (list
   "font8"
   "9836-alpha"
   "9836-color"
   "direct-physical-screen"
   "shared-physical-screen"
   "virtual-screen"
   ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% LAP support for Window operations
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(lap '((*entry mul16 expr 2)
       (move!.l (reg 1) (reg t1))
       (move!.l (reg 2) (reg t2))
       (muls (reg t1) (reg t2))
       (movea!.l (reg t2) (reg 1))
       (rts)
       ))

(lap '((*entry write-char-raster expr 4)

       % Arguments are:
       % 1. the raster pattern (vector of integers)
       % 2. the initial screen address (address of top scan line)
       % 3. the row-size (number of bytes per row of screen)
       % 4. count (the number of scan lines in the pattern) (must be positive)

       (move!.l (reg 4) (reg t2)) % loop control
       (addq!.l 4 (reg 1)) % skip vector header
       (*lbl (label loop))
       (move!.l (autoincrement (reg 1)) (reg t1)) % read next row from pattern
       (move!.b (reg t1) (displacement (reg 2) 0)) % store in screen memory
       (adda!.l (reg 3) (reg 2)) % advance to next row of screen
       (subq!.l 1 (reg t2)) % decrement loop counter
       (bgt (label loop)) % loop if more bytes to copy
       (move!.l (reg nil) (reg 1)) % avoid returning bad pointer
       (rts)
       ))

(lap '((*entry write-inverted-char-raster expr 4)

       % Arguments are:
       % 1. the raster pattern (vector of integers)
       % 2. the initial screen address (address of top scan line)
       % 3. the row-size (number of bytes per row of screen)
       % 4. count (the number of scan lines in the pattern) (must be positive)

       (move!.l (reg 4) (reg t2)) % loop control
       (addq!.l 4 (reg 1)) % skip vector header
       (*lbl (label loop))
       (move!.l (autoincrement (reg 1)) (reg t1)) % read next row from pattern
       (not!.l (reg t1)) % complement the raster pattern
       (move!.b (reg t1) (displacement (reg 2) 0)) % store in screen memory
       (adda!.l (reg 3) (reg 2)) % advance to next row of screen
       (subq!.l 1 (reg t2)) % decrement loop counter
       (bgt (label loop)) % loop if more bytes to copy
       (move!.l (reg nil) (reg 1)) % avoid returning bad pointer
       (rts)
       ))


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]