mirror of
https://github.com/PDP-10/its.git
synced 2026-03-24 09:30:29 +00:00
138 lines
4.6 KiB
Common Lisp
Executable File
138 lines
4.6 KiB
Common Lisp
Executable File
;;; -*- Mode:Lisp; IBase:10.; -*- Package created by KMP, 1/15/80
|
|
;;;
|
|
;;; BINPRT: A package for doing octal output (PDP10 only)
|
|
;;;
|
|
;;; This package is designed primarily for use as an interactive
|
|
;;; debugging tool, though it may have other applications as well. It
|
|
;;; defines the following functions:
|
|
;;;
|
|
;;; (BINPRINT object &optional stream) -- Terpri, BINPRIN1, Space
|
|
;;; (BINPRIN1 object &optional stream) -- Like PRIN1, but integers (at
|
|
;;; toplevel or imbedded will appear as nnnnnn,,nnnnnn (for fixnums)
|
|
;;; +nnnnnn,,nnnnnn_nnnnnn,,nnnnnn_... or
|
|
;;; -nnnnnn,,nnnnnn_nnnnnn,,nnnnnn_...
|
|
;;; (for bignums). If the switch BINPRINTYPE (Default NIL) is non-NIL
|
|
;;; fixnums and bignums will show up as above but with wrappers of
|
|
;;; #<FIXNUM ...> or #<BIGNUM ...> around them as appropriate.
|
|
;;;
|
|
;;; It should be emphasized that the output from this program is far from
|
|
;;; lisp-readable due to the free use of ",," but output is still visually
|
|
;;; parsable and that makes it a valuable aid in debugging bit-intensive code.
|
|
;;;
|
|
;;; Sample usage:
|
|
;;;
|
|
;;; (SETQ PRIN1 'BINPRIN1) => BINPRIN1
|
|
;;; 3 => 000000,,000003
|
|
;;; -1 => 777777,,777777
|
|
;;; '(3 5) => (000000,,000003 000000,,000005)
|
|
;;; (SETQ BINPRINTYPE T) => T
|
|
;;; -1 => #<FIXNUM 777777,,777777>
|
|
|
|
#-PDP10 (ERROR "This package not written to work except on a PDP10.")
|
|
|
|
(DECLARE (*LEXPR BINPRIN\NUM BINPRINT BINPRIN1)
|
|
(SPECIAL BINPRINTYPE))
|
|
|
|
(COND ((NOT (BOUNDP 'BINPRINTYPE))
|
|
(SETQ BINPRINTYPE NIL)))
|
|
|
|
(DEFUN BINPRIN\NUM (N &OPTIONAL (WHERE TYO) (TYPEFLAG BINPRINTYPE))
|
|
(DECLARE (SPECIAL CAR CDR))
|
|
(LET ((CAR T) (CDR T) (BASE (COND ((= BASE 2.) 2.) (T 8.))))
|
|
(COND (TYPEFLAG
|
|
(PRINC "#<" WHERE)
|
|
(PRINC (TYPEP N) WHERE)
|
|
(PRINC " " WHERE)))
|
|
(COND ((AND (OR (FIXP N) (FLOATP N)) (NOT (BIGP N)))
|
|
(SETQ N (LSH N 0.))
|
|
(DO ((I 33. (- I 3.)))
|
|
((MINUSP I))
|
|
(COND ((= I 15.) (PRINC ",," WHERE)))
|
|
(PRINC (LSH (BOOLE 1. N (LSH 7. I)) (- I)) WHERE)))
|
|
((BIGP N)
|
|
(COND ((NULL (CAR N)) (PRINC "+" WHERE))
|
|
(T (PRINC "-" WHERE)))
|
|
(DO ((L (CDR N) (CDR L)))
|
|
((NULL L))
|
|
(BINPRIN\NUM (CAR L) WHERE NIL)
|
|
(COND ((CDR L) (PRINC "_" WHERE)))))
|
|
(T
|
|
(PRINC "#<BINPRIN1 failure>" WHERE)))
|
|
(IF TYPEFLAG (PRINC ">"))))
|
|
|
|
(DECLARE (SPECIAL BINPRIN1-/`/,-LEVEL))
|
|
(SETQ BINPRIN1-/`/,-LEVEL 0.)
|
|
|
|
(DEFUN BINPRINT (FROB &OPTIONAL (STREAM TYO))
|
|
(TERPRI STREAM)
|
|
(BINPRIN1 FROB STREAM)
|
|
(TYO #\SPACE STREAM))
|
|
|
|
(DEFUN BINPRIN1 (FROB &OPTIONAL (STREAM TYO))
|
|
(DECLARE (SPECIAL CAR CDR))
|
|
(LET ((CAR T) (CDR T))
|
|
(COND ((FIXP FROB)
|
|
(BINPRIN\NUM FROB STREAM))
|
|
((ATOM FROB)
|
|
(PRIN1 FROB STREAM))
|
|
((HUNKP FROB)
|
|
(PRINC "(" STREAM)
|
|
(DO ((I 1. (1+ I))
|
|
(END (1- (HUNKSIZE FROB))))
|
|
((> I END))
|
|
(BINPRIN1 (CXR I FROB) STREAM)
|
|
(PRINC " . " STREAM))
|
|
(PRINC (CXR 0. FROB) STREAM)
|
|
(PRINC " .)" STREAM))
|
|
((AND (EQ (CAR FROB) 'QUOTE)
|
|
(= (LENGTH FROB) 2.))
|
|
(PRINC "'" STREAM)
|
|
(BINPRIN1 (CADR FROB) STREAM))
|
|
((EQ (CAR FROB) '|`-expander/||)
|
|
(LET ((BINPRIN1-/`/,-LEVEL (1+ BINPRIN1-/`/,-LEVEL)))
|
|
(PRINC "`" STREAM)
|
|
(BINPRIN1 (CDR FROB) STREAM)))
|
|
((AND (EQ (CAR FROB) '|`,/||) (> BINPRIN1-/`/,-LEVEL 0.))
|
|
(LET ((BINPRIN1-/`/,-LEVEL (1- BINPRIN1-/`/,-LEVEL)))
|
|
(PRINC "," STREAM)
|
|
(BINPRIN1 (CDR FROB) STREAM)))
|
|
((AND (EQ (CAR FROB) '|`,@/||) (> BINPRIN1-/`/,-LEVEL 0.))
|
|
(LET ((BINPRIN1-/`/,-LEVEL (1- BINPRIN1-/`/,-LEVEL)))
|
|
(PRINC ",@" STREAM)
|
|
(BINPRIN1 (CDR FROB) STREAM)))
|
|
((AND (EQ (CAR FROB) '|`,./||) (> BINPRIN1-/`/,-LEVEL 0.))
|
|
(LET ((BINPRIN1-/`/,-LEVEL (1- BINPRIN1-/`/,-LEVEL)))
|
|
(PRINC ",." STREAM)
|
|
(BINPRIN1 (CDR FROB) STREAM)))
|
|
((AND (EQ (CAR FROB) '|`.,/||) (> BINPRIN1-/`/,-LEVEL 0.))
|
|
(LET ((BINPRIN1-/`/,-LEVEL (1- BINPRIN1-/`/,-LEVEL)))
|
|
(PRINC ".," STREAM)
|
|
(BINPRIN1 (CDR FROB) STREAM)))
|
|
((AND (EQ (CAR FROB) 'MACROEXPANDED)
|
|
(GET (CADR FROB) 'MACRO))
|
|
(BINPRIN1 (NTH 3. FROB) STREAM))
|
|
((BIN$MEM '|`,/|| FROB)
|
|
(BINPRIN1
|
|
(DO ((L FROB (CDR L))
|
|
(NL () (CONS (CAR L) NL)))
|
|
((EQ (CAR L) '|`,/||)
|
|
(NREVERSE (CONS (CONS '|`.,/|| (CDR L)) NL))))
|
|
STREAM))
|
|
(T
|
|
(PRINC "(" STREAM)
|
|
(BINPRIN1 (CAR FROB) STREAM)
|
|
(DO ((F (CDR FROB) (CDR F)))
|
|
((ATOM F)
|
|
(COND ((NULL F) (PRINC ")" STREAM))
|
|
(T (PRINC " . " STREAM)
|
|
(BINPRIN1 F STREAM)
|
|
(PRINC ")" STREAM))))
|
|
(PRINC " " STREAM)
|
|
(BINPRIN1 (CAR F) STREAM))))))
|
|
|
|
(DEFUN BIN$MEM (X Y)
|
|
(DO ((L Y (CDR L)))
|
|
((ATOM L) NIL)
|
|
(COND ((EQ (CAR L) X) (RETURN L)))))
|
|
|