mirror of
https://github.com/PDP-10/its.git
synced 2026-02-07 08:57:06 +00:00
85994ed770
Resolves #284. Commented out uses of time-origin in maxtul; mcldmp (init) until we can figure out why it gives arithmetic overflows under the emulators. Updated the expect script statements in build_macsyma_portion to not attempt to match expected strings, but simply sleep for some time since in some cases the matching appears not to work.
83 lines
2.9 KiB
Common Lisp
83 lines
2.9 KiB
Common Lisp
;;;-*-Lisp-*-
|
|
|
|
; (c) Copyright 1976, 1983 Massachusetts Institute of Technology.
|
|
; All Rights Reserved. Enhancements (c) Copyright 1983 Symbolics Inc.
|
|
; All Rights Reserved.
|
|
;
|
|
; The data and information in the Enhancements is proprietary to, and a
|
|
; valuable trade secret of, SYMBOLICS, INC., a Delaware corporation. It is
|
|
; given in confidence by SYMBOLICS, and may not be used as the basis of
|
|
; manufacture, or be reproduced or copied, or distributed to any other
|
|
; party, in whole or in part, without the prior written consent of SYMBOLICS.
|
|
|
|
|
|
(declare (special char-height char-width print-line1 linel $plotheight
|
|
print-x print-y tty-graphics)
|
|
(fixnum x y x1 y1 ix iy ix1 iy1 i j k width print-x print-y sign char-height
|
|
char-width print-line1 linel $plotheight (prin-tyo fixnum)
|
|
(prin-tyo fixnum) (tyob0 fixnum))
|
|
(notype (print-line1 fixnum fixnum fixnum fixnum)
|
|
(print-char fixnum fixnum fixnum)
|
|
(putchar fixnum fixnum fixnum)
|
|
(print-point fixnum fixnum)))
|
|
|
|
;(setq char-height 22. char-width 12.)
|
|
|
|
(defun print-line1 (x y x1 y1)
|
|
((lambda (horiz sign)
|
|
(cond ((and (= x x1) (= y y1)) (print-point x y))
|
|
(horiz
|
|
(and (> x x1) (setq sign -1.))
|
|
(do ((ix (// x char-width) (+ sign ix)) (ix1 (// x1 char-width)))
|
|
((> (* sign ix) (* sign ix1)))
|
|
(putchar ix
|
|
(// (+ y (// (* (- y1 y)
|
|
(- (+ (* ix char-width) (// char-width 2.)) x))
|
|
(- x1 x)))
|
|
char-height)
|
|
print-line1)))
|
|
(t
|
|
(and (> y y1) (setq sign -1.))
|
|
(do ((iy (// y char-height) (+ sign iy)) (iy1 (// y1 char-height)))
|
|
((> (* sign iy) (* sign iy1)))
|
|
(putchar (// (+ x (// (* (- x1 x)
|
|
(- (+ (* iy char-height) (// char-height 2.)) y))
|
|
(- y1 y)))
|
|
char-width)
|
|
iy print-line1)))))
|
|
(> (* char-height (abs (- x1 x))) (* char-width (abs (- y1 y)))) 1.))
|
|
|
|
(defun print-point (x y) (print-char x y print-line1))
|
|
|
|
(defun print-char (x y i) (putchar (// x char-width) (// y char-height) i))
|
|
|
|
(defun putchar (x y i)
|
|
(setq y (1- (- $plotheight y)))
|
|
(or (< x 0.) (not (< x linel)) (< y 0) (not (< y $plotheight))
|
|
(< i 32.) (not (< i 127.))
|
|
(cond ((eq tty-graphics 'disp)
|
|
(cond ((not (and (= y print-y) (= x print-x)))
|
|
(prin-tyo 143.)
|
|
(prin-tyo y)
|
|
(prin-tyo x)
|
|
(setq print-y y)))
|
|
(prin-tyo i) (setq print-x (1+ x)))
|
|
((eq tty-graphics 'print)
|
|
(store (screen-array y x) i))))
|
|
nil)
|
|
|
|
(defun screen-output nil
|
|
(do ((flg) (k 0.) (i 0 (1+ i)) (width)) ((not (< i $plotheight)))
|
|
(do ((j (1- linel) (1- j)))
|
|
((or (< j 0.) (not (= (screen-array i j) 32.)))
|
|
(setq width j)))
|
|
(cond ((and (< width 0.) flg) (setq k (1+ k)))
|
|
((not (< width 0.))
|
|
(do ((j 0. (1+ j))) ((= j k)) (mterpri))
|
|
(setq flg t k 0.)
|
|
(do ((j 0. (1+ j))) ((> j width))
|
|
(tyo (screen-array i j)))
|
|
(mterpri)))))
|
|
|
|
#-franz (putprop 'prin-tyo (get 'tyob0 'subr) 'subr)
|
|
#+franz (putd 'prin-tyo (getd 'tyob0)) |