Return to common3.l CVS log

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

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

1.1       root        1: (setq rcs-common2-
                      2:    "$Header: common3.l,v 1.3 83/09/11 09:44:14 jkf 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))

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