Return to common3.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib

Annotation of 43BSD/ucb/lisp/lisplib/common3.l, revision 1.1.1.1

1.1       root        1: (setq rcs-common2-
                      2:    "$Header: common3.l,v 1.4 84/02/29 23:23:35 layer Exp $")
                      3: 
                      4: ;;
                      5: ;; common3.l                           -[Sat Sep 10 10:51:18 1983 by jkf]-
                      6: ;;
                      7: ;;
                      8: 
                      9: (declare (macros t))
                     10: 
                     11: (defun litatom macro (x)
                     12:   `(and (atom . ,(cdr x))
                     13:        (not (numberp . ,(cdr x)))))
                     14: 
                     15: ; This function really should compile optimally in-line
                     16: ;
                     17: (defun nequal (arg1 arg2)
                     18:   (not (equal arg1 arg2)))
                     19: 
                     20: (defun lineread (&rest args)
                     21:    (let (flag port)
                     22:       (mapc (function          ; get the options
                     23:               (lambda (x)
                     24:                  (cond ((portp x) (setq port x))
                     25:                        ((setq flag x)))))
                     26:            args)
                     27:       (cond ((not (and flag    ; flag for empty line
                     28:                       (eq (tyipeek port) #\lf)
                     29:                       (tyi port)))
                     30:             (prog (input)
                     31:                (setq input (ncons nil))  ; initialize for tconc.
                     32:                (tconc input (read port))       ; do read to make sure
                     33:                                                ; an s-expression gets read
                     34:                loop
                     35:                (cond ((not (eq (tyipeek port) #\lf))
                     36:                       (tconc input (read port))
                     37:                       (go loop))
                     38:                      ( t ; the actual list is in the CAR.
                     39:                        (tyi port)
                     40:                        (return (car input)))))))))
                     41: 
                     42: (defun defv fexpr (l)
                     43:   (set (car l) (cadr l)))
                     44: 
                     45: 
                     46: (defun initsym (&rest l)
                     47:    (mapcar (function initsym1) l))
                     48: 
                     49: (defun initsym1 expr (l)
                     50:    (prog (num)
                     51:       (cond ((dtpr l)
                     52:             (setq num (cadr l))
                     53:             (setq l (car l)))
                     54:            ( t (setq num 0)))
                     55:       (putprop l num 'symctr)
                     56:       (return (concat l num))))
                     57: 
                     58: (defun newsym (name)
                     59:    (concat name
                     60:           (putprop name
                     61:                    (1+ (or (get name 'symctr)
                     62:                            -1))
                     63:                    'symctr)))
                     64: 
                     65: (defun oldsym (sym)
                     66:    (cond ((get sym 'symctr) (concat sym (get sym 'symctr)))
                     67:         ( t sym)))
                     68: 
                     69: (defun allsym (name)
                     70:    (prog (num symctr syms)
                     71:       (cond ((dtpr name)
                     72:             (setq num (cadr name))
                     73:             (setq name (car name)))
                     74:            ( t (setq num 0)))
                     75:       (or (setq symctr (get name 'symctr))
                     76:          (return))
                     77:       loop
                     78:       (and (>& num symctr)
                     79:           (return syms))
                     80:       (setq syms (cons (concat name symctr) syms))
                     81:       (setq symctr (1- symctr))
                     82:       (go loop)))
                     83: 
                     84: (defun remsym (&rest l)
                     85:    (mapcar (function remsym1) l))
                     86: 
                     87: (defun remsym1 expr (l)
                     88:    (prog1 (oldsym (cond ((dtpr l) (car l))
                     89:                        ( t l)))
                     90:          (mapc (function remob) (allsym l))
                     91:          (cond ((dtpr l)
                     92:                 (putprop (car l) (1- (cadr l)) 'symctr))
                     93:                ( t (remprop l 'symctr)))))
                     94: 
                     95: (defun symstat (&rest l)
                     96:    (mapcar (function (lambda (k)
                     97:                        (list k (get k 'symctr))))
                     98:           l))
                     99: 
                    100: ;; from peter@renoir
                    101: (defun wide-print-list (given-list &optional (left-margin (nwritn)))
                    102:   ;    given a (presumably long) list, print it as wide as possible.
                    103:   (declare (special lpar rpar))
                    104:   (let ((max-width 78))
                    105:        (tab left-margin)
                    106:        (cond ((not (listp given-list))
                    107:              (patom given-list))
                    108:             ((null given-list)
                    109:              (patom nil))
                    110:             (t
                    111:              (patom lpar)
                    112:              (do ((left given-list (cdr left))
                    113:                   (need-space-p nil t))
                    114:                  ((null left) nil)
                    115:                  (cond (need-space-p
                    116:                         (patom " ")))
                    117:                  (let* ((element (car left))
                    118:                         (length (flatc element))
                    119:                         (used (nwritn))
                    120:                         (available (- max-width used)))
                    121:                        (cond ((>= length available)
                    122:                               (tab (1+ left-margin))))
                    123:                        (cond ((listp element)
                    124:                               (wide-print-list element))
                    125:                              (t
                    126:                               (patom element)))))
                    127:              (patom rpar)))))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.