Return to auxfns1.l CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib

Annotation of 3BSD/cmd/lisp/lib/auxfns1.l, revision 1.1

1.1     ! root        1: 
        !             2: 
        !             3: 
        !             4: ;--- msg - arg1 ...  arguments of the form described below
        !             5: ;      B - print out a blank
        !             6: ;      N - print out a newline (terpr)
        !             7: ;      (B n) - print out n blanks
        !             8: ;      (P p) - henceforth print on port p
        !             9: ;      atom - patom this exactly (no evaluation)
        !            10: ;      other - evaluate and patom this expression.
        !            11: ;
        !            12: (def msg
        !            13:   (macro (lis)
        !            14:         `(progn ,@(msgmake (cdr lis) 'nil))))
        !            15: 
        !            16: (eval-when (eval compile load)
        !            17:   (def msgmake
        !            18:        (lambda (forms outport)
        !            19:               ((lambda (thisform)
        !            20:                        
        !            21:                        (cond ((null forms) `((drain ,@outport)))
        !            22:                              ((and (eq 'B thisform) (setq thisform '" ") nil))
        !            23:                              ((eq 'N thisform) (cons `(terpr ,@outport)
        !            24:                                                      (msgmake (cdr forms) outport)))
        !            25:                              ((atom thisform) (cons `(patom ',thisform 
        !            26:                                                             ,@outport)
        !            27:                                                     (msgmake (cdr forms) outport)))
        !            28:                              ((eq 'P (car thisform)) (msgmake (cdr forms)
        !            29:                                                               `(,@(cdr thisform))))
        !            30:                              
        !            31:                              ((eq 'B (car thisform)) (cons `(printblanks ,@(cdr thisform)
        !            32:                                                                          ,outport)
        !            33:                                                            (msgmake (cdr forms) outport)))
        !            34:                              (t (cons `(patom ,thisform ,@outport)
        !            35:                                       (msgmake (cdr forms) outport)))))
        !            36:                (car forms)))))
        !            37: 
        !            38: (def printblanks
        !            39:   (lambda (n prt)
        !            40:          (do ((i n (sub1 i)))
        !            41:              ((lessp i 1))
        !            42:              (patom '" " prt))))
        !            43: 
        !            44: 
        !            45: 
        !            46: 
        !            47: ; ==============================================
        !            48: ;
        !            49: ;      (linelength [numb])
        !            50: ;
        !            51: ; sets the linelength (actually just varib linel) to the
        !            52: ; number given: numb
        !            53: ; if numb is not given, the current line length is returned
        !            54: ; =================================================
        !            55: 
        !            56: (setq linel 80)
        !            57: (def linelength
        !            58:      (nlambda (form)
        !            59:              (cond ((null form) linel )
        !            60:                    ((numberp (car form)) (setq linel (car form)))
        !            61:                    (t linel))))
        !            62: 
        !            63: ; ========================================
        !            64: ;
        !            65: ;      (charcnt port) 
        !            66: ; returns the number of characters left on the current line
        !            67: ; on the given port
        !            68: ;
        !            69: ; =======================================
        !            70: 
        !            71: 
        !            72: (def charcnt
        !            73:      (lambda (port) (diff linel (nwritn port))))
        !            74: 
        !            75: (def nthcdr
        !            76:  (lambda (n x)
        !            77:   (cond ((equal n 0) x)
        !            78:         ((lessp n 0) (cons nil x))
        !            79:         (t (nthcdr (sub1 n) (cdr x) )))))
        !            80: 
        !            81: ;r     lambda: (nthrest numb list)
        !            82: ;-     args:   numb - integer
        !            83: ;-             list - list
        !            84: ;-     returns:the rest of the list beginning at the numb'th element.
        !            85: ;-             for convience, (nthrest 0 list) equals (nthrest 1 list)
        !            86: ;-             equals list.  This is designed to be similar to nthelem
        !            87: ;-             which returns the nth element of a list.
        !            88: 
        !            89: (def nthrest
        !            90:   (lambda (number list)
        !            91:          (cond ((lessp number 2)  list)
        !            92:                (t (nthrest (sub1 number) (cdr list))))))
        !            93: 
        !            94: 
        !            95: ;;==============================
        !            96: ;  (assqr val alist)
        !            97: ; acts much like assq, it looks for val in the cdr of elements of
        !            98: ; the alist and returns the element if found.
        !            99: ; fix this when the compiler works
        !           100: (eval-when nil (def assqr 
        !           101:     (lambda (val alist)
        !           102:        (do ((al alist (cdr al)))
        !           103:            ((null al) nil)
        !           104:            (cond ((eq val (cdar al)) (return (car al))))))))
        !           105: 
        !           106: 
        !           107: ; ====================
        !           108: ; (listp 'x) is t if x is a non-atom or nil
        !           109: ; ====================
        !           110: (def listp (lambda (val) (or (dtpr val) (null val))))
        !           111: 
        !           112: 
        !           113: 
        !           114: ;--- memcar - VAL : lispval
        !           115: ;          - LIS : list
        !           116: ;      returns t if VAL found as the car of a top level element.
        !           117: ;temporarily turn this off till the compiler can handle it.
        !           118: (eval-when nil (def memcar 
        !           119:   (lambda (a l)
        !           120:          (do ((ll l (cdr ll)))
        !           121:              ((null ll) nil)
        !           122:              (cond ((equal (caar ll) a) (return (cdar ll))))))))
        !           123: 
        !           124: ; =================================
        !           125: ;
        !           126: ;      (memcdr 'val 'listl)
        !           127: ;
        !           128: ; the list listl is searched for a list
        !           129: ; with cdr equal to val. if found, the
        !           130: ; car of that list is returned.
        !           131: ; ==================================
        !           132: ;fix this when compiler works ok
        !           133: (eval-when nil (def memcdr 
        !           134:   (lambda (a l)
        !           135:          (do ((ll l (cdr ll)))
        !           136:              ((null ll) nil)
        !           137:              (cond ((equal (cdar ll) a) (return (caar l))))))))
        !           138: 
        !           139: 
        !           140: (def apply* 
        !           141:   (nlambda ($x$)
        !           142:        (eval (cons (eval (car $x$)) (cdr $x$)))))
        !           143: 
        !           144: 
        !           145: 
        !           146: 
        !           147: 
        !           148: ; =======================================
        !           149: ; pretty printer top level routine pp
        !           150: ;
        !           151: ; calling form- (pp arg1 arg2 ... argn)
        !           152: ; the args may be names of functions, atoms with associated values
        !           153: ; or output descriptors.
        !           154: ; if argi is:
        !           155: ;    an atom - it is assumed to be a function name, if there is no
        !           156: ;             function property associated with it,then it is assumed
        !           157: ;              to be an atom with a value
        !           158: ;    (P port)-  port is the output port where the results of the
        !           159: ;              pretty printing will be sent.
        !           160: ;              poport is the default if no (P port) is given.
        !           161: ;    (F fname)- fname is  a file name to write the results in
        !           162: ;    (A atmname) - means, treat this as an atom with a value, dont
        !           163: ;              check if it is the name of a function.
        !           164: ;
        !           165: (declare (special $outport$ $fileopen$ ))
        !           166: 
        !           167: ; printret is like print yet it returns the value printed, this is used
        !           168: ; by pp
        !           169: (def printret
        !           170:   (macro ($l$)
        !           171:         `(progn (print ,@(cdr $l$)) ,(cadr $l$))))
        !           172: 
        !           173: (def pp
        !           174:   (nlambda ($xlist$)
        !           175:        (prog ($outport$ $cur$ $fileopen$ $prl$ $atm$)
        !           176: 
        !           177:              (setq $outport$ poport)                   ; default port
        !           178:              ; check if more to do, if not close output file if it is
        !           179:              ; open and leave
        !           180: 
        !           181: 
        !           182:    toploop    (cond ((null (setq $cur$ (car $xlist$)))
        !           183:                     (condclosefile)
        !           184:                     (return t)))
        !           185: 
        !           186:              (cond ((dtpr $cur$)
        !           187:                     (cond ((equal 'P (car $cur$))      ; specifying a port
        !           188:                            (condclosefile)             ; close file if open
        !           189:                            (setq $outport$ (eval (cadr $cur$))))
        !           190: 
        !           191:                           ((equal 'F (car $cur$))      ; specifying a file
        !           192:                            (condclosefile)             ; close file if open
        !           193:                            (setq $outport$ (outfile (cadr $cur$))
        !           194:                                  $fileopen$ t))
        !           195: 
        !           196:                           ((equal 'A (car $cur$))      ; declaring atomness
        !           197:                            (setq $atm$ t)
        !           198:                            (setq $cur$ (cadr $cur$))
        !           199:                            (go midstuff))
        !           200: 
        !           201:                           ((eq 'V (car $cur$))         ; print value only
        !           202:                            (setq $atm$ 'value)
        !           203:                            (setq $cur$ (cadr $cur$))
        !           204:                            (go midstuff))
        !           205: 
        !           206:                           (t (msg N "bad arg to pp: " (or $cur$))))
        !           207:                     (go botloop)))
        !           208:  midstuff     ; process the atom or function
        !           209:              
        !           210:              (cond ((eq 'value $atm$)
        !           211:                     (setq $prl$ (eval $cur$)))
        !           212: 
        !           213:                    ((or $atm$ (null (getd $cur$)))     ; check if is atom
        !           214:                     (cond ((boundp $cur$)              ; yes, see if bound
        !           215:                            (setq $prl$ (list 'setq $cur$ (list 'quote 
        !           216:                                                                (eval $cur$)))))
        !           217:                           (t (msg N "pp: atom " (or $cur$) " is unbound")
        !           218:                              (go botloop))))
        !           219: 
        !           220:                    ((bcdp (getd $cur$))                ; is a fcn, see if bcd
        !           221:                     (msg N "pp: function " (or $cur$) " is machine coded (bcd) ")
        !           222:                     (go botloop))
        !           223: 
        !           224:                    (t (setq $prl$ (list 'def $cur$ (getd $cur$)))))
        !           225: 
        !           226:              ; now print it
        !           227: 
        !           228:              ($prpr $prl$)
        !           229:              (terpr $outport$)
        !           230:              (setq $atm$ nil)                          ; clear flag
        !           231: 
        !           232:  botloop      (setq $xlist$ (cdr $xlist$))
        !           233: 
        !           234:              (go toploop))))
        !           235: 
        !           236: 
        !           237: 
        !           238: (def condclosefile 
        !           239:   (lambda nil
        !           240:          (cond ($fileopen$
        !           241:                 (terpr $outport$)
        !           242:                 (close $outport$)
        !           243:                 (setq $fileopen$ nil)))))
        !           244: 
        !           245: ;
        !           246: ; these routines are meant to be used by pp but since
        !           247: ; some people insist on using them we will set $outport$ to nil
        !           248: ; as the default
        !           249: (setq $outport$ nil)
        !           250: 
        !           251: 
        !           252: (def $prpr 
        !           253:   (lambda (x)
        !           254:          (cond ((not (boundp '$outport$)) (setq $outport$ poport)))
        !           255:          (terpr $outport$)
        !           256:          ($prdf x 0 0)))
        !           257: 
        !           258: 
        !           259: (declare (special m))
        !           260: 
        !           261: (def $prdf 
        !           262:   (lambda (l n m)
        !           263:          (prog ()
        !           264:                ($tocolumn n)
        !           265:           a    (cond ((or (atom l)
        !           266:                           (lessp (add m (flatsize l (chrct $outport$)))
        !           267:                                  (chrct $outport$)))
        !           268:                       (return (printret l $outport$)))
        !           269:                      ((and ($patom1 lpar)
        !           270:                            (lessp 2 (length l))
        !           271:                            (atom (car l)))
        !           272:                       (prog (c f g h)
        !           273:                             (setq g
        !           274:                                   (cond ((member (car l) '(lambda nlambda))
        !           275:                                          -7)
        !           276:                                         (t
        !           277:                                          0)))
        !           278:                             (setq f (equal (printret (car l) $outport$) 'prog))
        !           279:                             ($patom1 ' " ")
        !           280:                             (setq c ($dinc))
        !           281:                           a ($prd1
        !           282:                              (cdr l)
        !           283:                              (add
        !           284:                               c
        !           285:                               (cond ((setq h (and f
        !           286:                                                   (cadr l)
        !           287:                                                   (atom (cadr l))))
        !           288:                                      -5)
        !           289:                                     (t g))))
        !           290:                             (cond ((cdr (setq l (cdr l)))
        !           291:                                    (cond ((or (null h) (atom (cadr l)))
        !           292:                                           (terpr $outport$)))
        !           293:                                    (go a)))))
        !           294:                      ((prog (c)
        !           295:                             (setq c ($dinc))
        !           296:                         a   ($prd1 l c)
        !           297:                             (cond ((setq l (cdr l))
        !           298:                                    (terpr $outport$)
        !           299:                                    (go a))))))
        !           300:          b     ($patom1 rpar))))
        !           301: 
        !           302: 
        !           303: 
        !           304: (def $prd1 
        !           305:   (lambda (l n)
        !           306:          (prog ()
        !           307:                ($prdf (car l)
        !           308:                       n
        !           309:                       (cond ((null (setq l (cdr l))) (add m 1))
        !           310:                             ((atom l) (setq n nil) (plus 4 m (pntlen l)))
        !           311:                             (t m)))
        !           312:                (cond ((null n)
        !           313:                       ($patom1 ' " . ")
        !           314:                       (return (printret l $outport$)))))))
        !           315: 
        !           316: 
        !           317: 
        !           318: 
        !           319: 
        !           320: (def $dinc (lambda () (diff (linelength $outport$) (chrct $outport$))))
        !           321: 
        !           322: 
        !           323: (def $tocolumn
        !           324:   (lambda (n)
        !           325:          (cond ((greaterp (setq n (diff n (nwritn $outport$))) 0)
        !           326:                 (do ((i 0 (add1 i)))
        !           327:                     ((equal i n))
        !           328:                     (patom '" " $outport$))))))
        !           329: 
        !           330: ; ========================================
        !           331: ;
        !           332: ;      (charcnt port) 
        !           333: ; returns the number of characters left on the current line
        !           334: ; on the given port
        !           335: ;
        !           336: ; =======================================
        !           337: 
        !           338: 
        !           339: (def charcnt
        !           340:      (lambda (port) (diff linel (nwritn port))))
        !           341: 
        !           342: (putd 'chrct (getd 'charcnt))
        !           343: 
        !           344: (def $patom1 (lambda (x) (patom x $outport$)))

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