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     ! 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.