Return to ucisubset.l CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / pearl

Annotation of 43BSDReno/pgrm/lisp/pearl/ucisubset.l, revision 1.1

1.1     ! root        1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ucisubset.l ;;;;;;;;;;;;;;;;;;;;;;;;;
        !             2: ; Functions for a subset of UCI Lisp that are either used by PEARL
        !             3: ;     or were needed by PEARL users at Berkeley.
        !             4: ; This was purposely designed to interfere as little as necessary
        !             5: ;     with Franz Lisp, so things like the standard UCI do macro
        !             6: ;     and the Charniak (et al) let macro are not provided.
        !             7: ; Includes what used to be sprint.l (at the end).
        !             8: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             9: ; Copyright (c) 1983 ,  The Regents of the University of California.
        !            10: ; All rights reserved.  
        !            11: ; Authors: Joseph Faletti and Michael Deering.
        !            12: 
        !            13: (eval-when (compile)
        !            14:   (declare (special defmacro-for-compiling *savedefs*))
        !            15:   (setq defmacro-for-compiling t)
        !            16:   (setq *savedefs* nil))
        !            17: 
        !            18: (declare (macros t))
        !            19: 
        !            20: (defvar poport)
        !            21: (defvar pparm1 50)
        !            22: (defvar pparm2 100)
        !            23: (defvar lpar)
        !            24: (defvar rpar)
        !            25: (defvar form)
        !            26: (defvar linel)
        !            27: (defvar *outport* nil)
        !            28: (defvar *fileopen*)
        !            29: (defvar prettyprops '((comment . pp-comment)
        !            30:                      (function . pp-function)
        !            31:                      (value . pp-value)))
        !            32: 
        !            33: (declare (localf *patom1))
        !            34: 
        !            35: (defvar *file* nil)
        !            36: (defvar *oldfunctiondefinition*)
        !            37: (defvar *savedefs* t)
        !            38: 
        !            39: (defmacro funl (&rest rest)
        !            40:   `(function (lambda .,rest)))
        !            41: 
        !            42: ;
        !            43: ; ucilisp (de df dm) declare function macros.
        !            44: ;
        !            45: ; (DE name args body) -> declare exprs and lexprs.
        !            46: ;   If *savedefs* is t and function has previous definition,
        !            47: ;   save it under the property OLDDEF, and return '(name Redefined).
        !            48: ;   Otherwise, just do a defun and return name (as with defun).
        !            49: ;
        !            50: (defun de macro (l)
        !            51:   (cond (*savedefs*
        !            52:         `(progn 'compile
        !            53:                 (setq *oldfunctiondefinition* (getd ',(cadr l)))
        !            54:                 (defun .,(cdr l))
        !            55:                 (and *file*
        !            56:                      (putprop ',(cadr l) *file* 'sourcefile))
        !            57:                 (cond (*oldfunctiondefinition*
        !            58:                        (putprop ',(cadr l) *oldfunctiondefinition* 'olddef)
        !            59:                        (list ',(cadr l) 'Redefined))
        !            60:                       ( t ',(cadr l)))))
        !            61:        ( t `(defun .,(cdr l)))))
        !            62:   
        !            63: ;
        !            64: ; (df name args body) -> declare fexprs.
        !            65: ;
        !            66: (defun df macro (l) 
        !            67:   (cond (*savedefs*
        !            68:         `(progn 'compile
        !            69:                 (setq *oldfunctiondefinition* (getd ',(cadr l)))
        !            70:                 (defun ,(cadr l) fexpr .,(cddr l))
        !            71:                 (and *file*
        !            72:                      (putprop ',(cadr l) *file* 'sourcefile))
        !            73:                 (cond (*oldfunctiondefinition*
        !            74:                        (putprop ',(cadr l) *oldfunctiondefinition* 'olddef)
        !            75:                        (list ',(cadr l) 'Redefined))
        !            76:                       ( t ',(cadr l)))))
        !            77:        ( t `(defun ,(cadr l) fexpr .,(cddr l)))))
        !            78: 
        !            79: ;
        !            80: ; macro's are not compiled except under the same
        !            81: ;      conditions as in franz lisp.
        !            82: ;      (usually just do (declare (macros t))
        !            83: ;              to have macros also compiled).
        !            84: ;
        !            85: ;
        !            86: ; (dm name args body) -> declare macros. same as (defun name 'macro body)
        !            87: ;
        !            88: (defun dm macro (l) 
        !            89:   (cond (*savedefs*
        !            90:         `(progn 'compile
        !            91:                 (setq *oldfunctiondefinition* (getd ',(cadr l)))
        !            92:                 (defun ,(cadr l) macro .,(cddr l))
        !            93:                 (and *file*
        !            94:                      (putprop ',(cadr l) *file* 'sourcefile))
        !            95:                 (cond (*oldfunctiondefinition*
        !            96:                        (putprop ',(cadr l) *oldfunctiondefinition* 'olddef)
        !            97:                        (list ',(cadr l) 'Redefined))
        !            98:                       ( t ',(cadr l)))))
        !            99:        ( t `(defun ,(cadr l) macro .,(cddr l)))))
        !           100: 
        !           101: ; UCI Lisp character macros are non-separating when occurring in 
        !           102: ;    the middle of atoms.
        !           103: (eval-when (compile load eval)
        !           104:   (add-syntax-class 'vucisplicemacro
        !           105:                    '(csplicing-macro escape-when-first))
        !           106:   (add-syntax-class 'vucireadmacro
        !           107:                    '(cmacro escape-when-first)))
        !           108: 
        !           109: ;
        !           110: ; ucilisp functions which declare character macros.
        !           111: ;
        !           112: ;
        !           113: ; dsm - declare splicing read macro.
        !           114: ;
        !           115: (defun dsm macro (l) 
        !           116:   (cond (*savedefs*
        !           117:         `(progn 'compile
        !           118:                 (setq *oldfunctiondefinition*
        !           119:                       (and (memq (getsyntax ',(cadr l))
        !           120:                                  '(vucireadmacro vucisplicemacro
        !           121:                                                  vsplicing-macro vmacro))
        !           122:                            (get ',(cadr l) readtable)))
        !           123:                 (eval-when (compile load eval)
        !           124:                            (setsyntax ',(cadr l) 'vucisplicemacro ',(caddr l)))
        !           125:                 
        !           126:                 (and *file*
        !           127:                      (putprop ',(cadr l) *file* 'sourcefile))
        !           128:                 (cond (*oldfunctiondefinition*
        !           129:                        (putprop ',(cadr l) *oldfunctiondefinition* 'oldmacro)
        !           130:                        (list ',(cadr l) 'Redefined))
        !           131:                       ( t ',(cadr l)))))
        !           132:        ( t `(eval-when (compile load eval)
        !           133:                        (setsyntax ',(cadr l) 'vucisplicemacro ',(caddr l))))))
        !           134: 
        !           135: ;
        !           136: ; drm - declare read macro.
        !           137: ;
        !           138: (defun drm macro (l) 
        !           139:   (cond (*savedefs*
        !           140:         `(progn 'compile
        !           141:                 (setq *oldfunctiondefinition*
        !           142:                       (and (memq (getsyntax ',(cadr l))
        !           143:                                  '(vucireadmacro vucisplicemacro
        !           144:                                                  vsplicing-macro vmacro))
        !           145:                            (get ',(cadr l) readtable)))
        !           146:                 (eval-when (compile load eval)
        !           147:                            (setsyntax ',(cadr l) 'vucireadmacro ',(caddr l)))
        !           148:                 
        !           149:                 (and *file*
        !           150:                      (putprop ',(cadr l) *file* 'sourcefile))
        !           151:                 (cond (*oldfunctiondefinition*
        !           152:                        (putprop ',(cadr l) *oldfunctiondefinition* 'oldmacro)
        !           153:                        (list ',(cadr l) 'Redefined))
        !           154:                       ( t ',(cadr l)))))
        !           155:        ( t `(eval-when (compile load eval)
        !           156:                        (setsyntax ',(cadr l) 'vucireadmacro ',(caddr l))))))
        !           157: 
        !           158: ;
        !           159: ; ucilisp selectq function. (written by jkf)
        !           160: ;
        !           161: (defun selectq* macro (form)
        !           162:   ((lambda (x)
        !           163:           `((lambda (,x)
        !           164:                     (cond 
        !           165:                      ,@(maplist 
        !           166:                         (function
        !           167:                          (lambda (ff)
        !           168:                                  (cond ((null (cdr ff))
        !           169:                                         `( t  ,(car ff)))
        !           170:                                        ((atom (caar ff))
        !           171:                                         `((eq ,x ',(caar ff))
        !           172:                                           . ,(cdar ff)))
        !           173:                                        (t
        !           174:                                         `((memq ,x ',(caar ff))
        !           175:                                           . ,(cdar ff))))))
        !           176:                         (cddr form))))
        !           177:             ,(cadr form)))
        !           178:    (gensym 'z)))
        !           179: 
        !           180: (defun some macro (l)
        !           181:   `((lambda (f a)
        !           182:            (prog ()
        !           183:                  loop
        !           184:                  (cond ((null a) (return nil))
        !           185:                        ((funcall f (car a))
        !           186:                         (return a))
        !           187:                        ( t (setq a (cdr a))
        !           188:                            (go loop)))))
        !           189:     ,(cadr l)
        !           190:     ,(caddr l)))
        !           191: 
        !           192: (defmacro subset (fun lis)
        !           193:   `(mapcan (function (lambda (ele)
        !           194:                             (cond ((funcall ,fun ele) (ncons ele)))))
        !           195:           ,lis))
        !           196:   
        !           197: (defun length (l)
        !           198:   (prog (n)
        !           199:        (setq n 0)
        !           200:        loop
        !           201:        (and (atom l) 
        !           202:             (return n))
        !           203:        (setq l (cdr l))
        !           204:        (setq n (1+ n))
        !           205:        (go loop)))
        !           206: 
        !           207: (defmacro apply* (fcn args)
        !           208:   `(prog (fcndef)
        !           209:         (return
        !           210:          (cond ((atom ,fcn)
        !           211:                 (or (and (eq 'binary (type ,fcn))
        !           212:                          (setq fcndef ,fcn))
        !           213:                     (setq fcndef (getd ,fcn)))
        !           214:                 (cond ((or (and (eq 'binary (type fcndef))
        !           215:                                 (eq 'macro (getdisc fcndef)))
        !           216:                            (and (dtpr fcndef)
        !           217:                                 (eq 'macro (car fcndef))))
        !           218:                        (funcall ,fcn (cons ,fcn ,args)))
        !           219:                       ( t (apply ,fcn ,args))))
        !           220:                ( t (apply ,fcn ,args))))))
        !           221: 
        !           222: (defmacro every (fcn args)
        !           223:   `(prog (kkkk)
        !           224:         (setq kkkk ,args)
        !           225:         loop
        !           226:         (cond ((null kkkk)
        !           227:                (return t))
        !           228:               ((apply* ,fcn (list (pop kkkk)))
        !           229:                (go loop)))
        !           230:         (return nil)))
        !           231: 
        !           232: (defun timer fexpr (request)
        !           233:   (let ((timein (ptime)) timeout result cpu garbage)
        !           234:        (prog ()
        !           235:             loop
        !           236:             (setq result (eval (car request)))
        !           237:             (and (setq request (cdr request))
        !           238:                  (go loop)))
        !           239:        (setq timeout (ptime))
        !           240:        (setq cpu (quotient (fix (times 1000
        !           241:                                       (quotient (difference (car timeout)
        !           242:                                                             (car timein))
        !           243:                                                 60.0)))
        !           244:                           1000.0))
        !           245:        (setq garbage (quotient (fix (times 1000
        !           246:                                           (quotient (difference (cadr timeout)
        !           247:                                                                 (cadr timein))
        !           248:                                                     60.0)))
        !           249:                               1000.0))
        !           250:        (print (cons cpu garbage))
        !           251:        (terpri)
        !           252:        result))
        !           253: 
        !           254: (putd 'consp (getd 'dtpr))
        !           255: 
        !           256: (putd 'msgprintfn (getd 'patom))
        !           257:   
        !           258: ;
        !           259: ; ucilisp msg function. (written by jkf)
        !           260: ;
        !           261: (defmacro msg ( &rest body)
        !           262:   `(progn ,@(mapcar 
        !           263:             (function
        !           264:              (lambda (form)
        !           265:                      (cond ((eq form t) '(line-feed 1))
        !           266:                            ((numberp form)
        !           267:                             (cond ((>& form 0) 
        !           268:                                    `(msg-space ,form))
        !           269:                                   ( t `(line-feed ,(minus form)))))
        !           270:                            ((atom form) `(msgprintfn ,form))
        !           271:                            ((eq (car form) t) '(msgprintfn '\  ))
        !           272:                            ((eq (car form) 'e) 
        !           273:                             `(msgprintfn ,(cadr form)))
        !           274:                            ( t `(msgprintfn ,form)))))
        !           275:             body)
        !           276:          nil)) ; return nil!
        !           277:   
        !           278: ;
        !           279: ; this NEED NOT be fixed to not use do.
        !           280: ;
        !           281: (defmacro msg-space (n)
        !           282:   (cond ((eq 1 n) '(patom '" "))
        !           283:        ( t `(do i ,n (1- i) (<& i 1) (patom '\ ))))) 
        !           284: 
        !           285: (defmacro line-feed (n)
        !           286:   (cond ((eq 1 n) '(terpr))
        !           287:        ( t `(do i ,n (1- i) (<& i 1) (terpr)))))
        !           288: 
        !           289: ; compatability functions: functions required by uci lisp but not
        !           290: ;      present in franz
        !           291: ;
        !           292: ; union uses the franz do loop (not the ucilisp one).
        !           293: 
        !           294: (defvar membfn 'member)
        !           295: 
        !           296: (defun union n
        !           297:   (and (> n 0)
        !           298:        (do ((res (ncons nil))
        !           299:            (i 1 (1+ i)))
        !           300:           ((eq i (1+ n)) (car res))
        !           301:           (mapc (function
        !           302:                    (lambda (arg)
        !           303:                       (or (apply* membfn (list arg (car res)))
        !           304:                           (tconc res arg))))
        !           305:                 (arg i)))))
        !           306: 
        !           307: (defun enter (v l)
        !           308:   (cond ((apply* membfn (list v l)) l)
        !           309:        ( t (cons v l))))
        !           310: 
        !           311: (defun append2 (a b &aux (c (ncons nil)))
        !           312:       (do ((a a (cdr a)))
        !           313:          ((null a))
        !           314:          (tconc c (car a)))
        !           315:       (rplacd (cdr c) b)
        !           316:       (car c))
        !           317: 
        !           318: (putd 'noduples (getd 'union))
        !           319: (putd 'append* (getd 'append))
        !           320: (putd '*append (getd 'append))
        !           321: (putd '*dif (getd 'diff))
        !           322: (putd '*eval (getd 'eval))
        !           323: (putd '*great (getd 'greaterp))
        !           324: (putd '*less (getd 'lessp))
        !           325: (putd '*max (getd 'max))
        !           326: (putd '*nconc (getd 'nconc))
        !           327: (putd '*plus (getd 'plus))
        !           328: (putd '*times (getd 'times))
        !           329: (putd 'expandmacro (getd 'macroexpand))
        !           330: (putd 'mapcl (getd 'mapcar))
        !           331: (putd 'memb (getd 'member))
        !           332: 
        !           333: (dm clrbfi () 
        !           334:  '(drain piport))
        !           335: 
        !           336: (defun save fexpr (l)
        !           337:   (let ((fcnname (car l)))
        !           338:        (putprop fcnname (getd fcnname) 'olddef)))
        !           339: 
        !           340: (defun unsave fexpr (l) 
        !           341:   (let* ((name (car l))
        !           342:         (old (get name 'olddef)))
        !           343:        (and old
        !           344:             (putprop name (getd name) 'olddef)
        !           345:             (putd name old))
        !           346:        old))
        !           347: 
        !           348: (putd 'atcat (getd 'concat))
        !           349: 
        !           350: (putd 'gt (getd '>))
        !           351: (putd 'lt (getd '<))
        !           352: 
        !           353: (defun le macro (x)
        !           354:   `(not (> .,(cdr x))))
        !           355: 
        !           356: (defun ge macro (x)
        !           357:   `(not (< .,(cdr x))))
        !           358: 
        !           359: (defun litatom macro (x)
        !           360:   `(and (atom .,(cdr x))
        !           361:        (not (numberp .,(cdr x)))))
        !           362: 
        !           363: (putd 'peekc (getd 'tyipeek))
        !           364: 
        !           365: ;
        !           366: ;      unbound - (setq x (unbound)) will unbind x.
        !           367: ; "this [code] is sick" - jkf.
        !           368: ;
        !           369: (defun unbound macro (l)
        !           370:   `(fake -4))
        !           371: 
        !           372: (or (getd 'franzboundp)
        !           373:   (putd 'franzboundp (getd 'boundp)))
        !           374: 
        !           375: (defun boundp (item)
        !           376:   (cond ((arrayp item))
        !           377:        ((franzboundp item))))
        !           378: 
        !           379: (defvar *dskin* t)
        !           380: (defvar piport)
        !           381: 
        !           382: ;(eval-when (load eval compile)
        !           383: ;  (or (boundp '*dskin*)
        !           384: ;      (setq *dskin* t)))
        !           385: 
        !           386: (eval-when (load eval)
        !           387:   (or (getd 'dskprintfn)
        !           388:       (putd 'dskprintfn (getd 'patom))))
        !           389: 
        !           390: (defun dskin fexpr (l)
        !           391:   (mapc 'dskin1 l)
        !           392:   (terpri) t )
        !           393: 
        !           394: (defun dskin1 (*file*)
        !           395:   (prog (port)
        !           396:        (terpri)
        !           397:        (patom '|>>>|)
        !           398:        (cond ((null (setq port (car (errset (infile *file*) nil))))
        !           399:                     (patom '|couldn't open file |)
        !           400:                     (patom *file*))
        !           401:              ( t (patom *file*)
        !           402:                  (patom '| |)
        !           403:                  (dskin2 port)
        !           404:                  (close port)))))
        !           405: 
        !           406: (defun dskin2 (port)
        !           407:   (prog (expr value)
        !           408:     loop
        !           409:       (cond ((null (setq expr (read port))) nil)
        !           410:            ( t (cond ((memq (car expr) '(de df defmacro dm drm
        !           411:                                             dsm setq def defun))
        !           412:                       (cond ((memq *dskin* '(name both))
        !           413:                              (patom (cadr expr))
        !           414:                              (patom '|: |))))
        !           415:                      ((eq (car expr) 'create)
        !           416:                       (cond ((memq *dskin* '(name both))
        !           417:                              (patom (caddr expr))
        !           418:                              (patom '|: |)))))
        !           419:                (setq value (eval expr))
        !           420:                (and (memq *dskin* '(t both))
        !           421:                     (or (eq value '*invisible*)
        !           422:                         (progn (dskprintfn value)
        !           423:                                (patom '| |))))
        !           424:                (go loop)))))
        !           425: 
        !           426: (defun nequal (arg1 arg2)
        !           427:   (not (equal arg1 arg2)))
        !           428: 
        !           429: (defun readl fexpr (l)
        !           430:   (cond ((null l) (readl1 nil))
        !           431:        ( t (readl1 (eval (car l))))))
        !           432: 
        !           433: (putd 'lineread (getd 'readl))
        !           434: 
        !           435: (defun readl1 (flag)
        !           436:   (cond ((not (and flag
        !           437:                   (eq (tyipeek) 10)
        !           438:                   (tyi)))
        !           439:         (prog (input)
        !           440:               (setq input (ncons nil))  ; initialize for tconc.
        !           441:               loop
        !           442:               (cond ((not (eq (tyipeek) 10))
        !           443:                      (tconc input (read))
        !           444:                      (go loop))
        !           445:                     ( t ; the actual list is in the CAR.
        !           446:                         (tyi)
        !           447:                         (return (car input))))))))
        !           448: 
        !           449: (defun defv fexpr (l)
        !           450:   (set (car l) (cadr l)))
        !           451: 
        !           452: (defun remprops (item proplist)
        !           453:   (mapc (funl (prop)
        !           454:              (remprop item prop))
        !           455:        proplist)
        !           456:   nil)
        !           457: 
        !           458: (defun addprop (id value prop)
        !           459:   (putprop id (enter value (get id prop)) prop))
        !           460: 
        !           461: (defun nconc1 (l elmt)
        !           462:   (rplacd (last l) (cons elmt nil)))
        !           463: 
        !           464: (defun dremove (elmt l)
        !           465:   (let (newl)
        !           466:        (cond ((dtpr l)
        !           467:              (cond ((eq elmt (car l))
        !           468:                     (setq newl (delq elmt l))
        !           469:                     (rplaca l (car newl))
        !           470:                     (rplacd l (cdr newl)))
        !           471:                    ( t (delq elmt l))))
        !           472:             ( t l))))
        !           473: 
        !           474: (defun intersection (set1 set2)
        !           475:   (prog (inter)
        !           476:        (mapc (funl (elt) (putprop elt t '*inter*)) set1)
        !           477:        (mapc (funl (elt) (and (get elt '*inter*)
        !           478:                               (setq inter (cons elt inter))))
        !           479:              set2)
        !           480:        (mapc (funl (elt) (remprop elt '*inter*)) set1)
        !           481:        (return inter)))
        !           482: 
        !           483: (defun initsym1 expr (l)
        !           484:   (prog (num)
        !           485:        (cond ((dtpr l)
        !           486:               (setq num (cadr l))
        !           487:               (setq l (car l)))
        !           488:              ( t (setq num 0)))
        !           489:        (putprop l num 'symctr)
        !           490:        (return (concat l num))))
        !           491: 
        !           492: (defun initsym fexpr (l)
        !           493:   (mapcar (function initsym1) l))
        !           494: 
        !           495: (defun newsym fexpr (l)
        !           496:   (let ((name (car l)))
        !           497:        (concat name
        !           498:               (putprop name
        !           499:                        (1+ (or (get name 'symctr)
        !           500:                                -1))
        !           501:                        'symctr))))
        !           502: 
        !           503: (defun oldsym fexpr (l)
        !           504:   (let ((sym (car l)))
        !           505:        (concat sym (get sym 'symctr))))
        !           506: 
        !           507: (defun allsym fexpr (l)
        !           508:   (prog (num symctr syms)
        !           509:        (cond ((dtpr (car l))
        !           510:               (setq num (cadar l))
        !           511:               (setq l (caar l)))
        !           512:              ( t (setq num 0)
        !           513:                  (setq l (car l))))
        !           514:        (or (setq symctr (get l 'symctr))
        !           515:            (return))
        !           516:        loop
        !           517:        (and (>& num symctr)
        !           518:             (return syms))
        !           519:        (setq syms (cons (concat l symctr) syms))
        !           520:        (setq symctr (1- symctr))
        !           521:        (go loop)))
        !           522: 
        !           523: (defun remsym1 expr (l)
        !           524:   (prog1 (funcall (function oldsym)
        !           525:                  (cond ((dtpr (car l)) (car l))
        !           526:                        ( t  l)))
        !           527:         (mapc (function remob) (apply (function allsym) l))
        !           528:         (cond ((dtpr (car l)) (putprop (caar l) (1- (cadar l)) 'symctr))
        !           529:               ( t (remprop (car l) 'symctr)))))
        !           530: 
        !           531: (defun remsym fexpr (l)
        !           532:   (maplist (function remsym1) l))
        !           533: 
        !           534: (defun symstat fexpr (l)
        !           535:   (mapcar (funl (k)
        !           536:                (list k (get k 'symctr)))
        !           537:          l))
        !           538: 
        !           539: (defun suflist (itemlist num)
        !           540:   (cond ((dtpr itemlist) (nth (1+ num) itemlist))))
        !           541: 
        !           542: ;;;;;;;;;;;;;;;;;;;;;;; (formerly sprint.l) ;;;;;;;;;;;;;;;;;;;;;;;;
        !           543: ;  A few additions to the library file ucbpp.l, mostly to add
        !           544: ;  a UCI Lisp-like "sprint" including some modifications for
        !           545: ;     more flexible printmacros.
        !           546: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !           547: 
        !           548: ; Moved to front and converted to defvar.
        !           549: ; (declare (special poport pparm1 pparm2 lpar rpar form linel))
        !           550: ; (declare (localf *patom1))
        !           551: ; (declare (special *outport* *fileopen* prettyprops))
        !           552: 
        !           553: ; =======================================
        !           554: ; pretty printer top level routine pp
        !           555: ;
        !           556: ;
        !           557: ; calling form- (pp arg1 arg2 ... argn)
        !           558: ; the args may be names of functions, atoms with associated values
        !           559: ; or output descriptors.
        !           560: ; if argi is:
        !           561: ;    an atom - it is assumed to be a function name, if there is no
        !           562: ;             function property associated with it,then it is assumed
        !           563: ;              to be an atom with a value
        !           564: ;    (P port)-  port is the output port where the results of the
        !           565: ;              pretty printing will be sent.
        !           566: ;              poport is the default if no (P port) is given.
        !           567: ;    (F fname)- fname is  a file name to write the results in
        !           568: ;    (A atmname) - means, treat this as an atom with a value, dont
        !           569: ;              check if it is the name of a function.
        !           570: ;    (E exp)-   evaluate exp without printing anything
        !           571: ;    other -   pretty-print the expression as is - no longer an error
        !           572: ;
        !           573: ;    Also, rather than printing only a function defn or only a value, we will
        !           574: ;    let prettyprops decide which props to print.  Finally, prettyprops will
        !           575: ;    follow the CMULisp format where each element is either a property
        !           576: ;    or a dotted pair of the form (prop . fn) where in order to print the
        !           577: ;    given property we call (fn id val prop).  The special properties
        !           578: ;    function and value are used to denote those "properties" which
        !           579: ;    do not actually appear on the plist.
        !           580: ;
        !           581: ; [history of this code: originally came from Harvard Lisp, hacked to
        !           582: ; work under franz at ucb, hacked to work at cmu and finally rehacked
        !           583: ; to work without special cmu macros]
        !           584: ; THEN, hacked to use for PEARL.
        !           585: 
        !           586: ; moved to front.
        !           587: ;(setq prettyprops '((comment . pp-comment)
        !           588: ;                  (function . pp-function)
        !           589: ;                  (value . pp-value)))
        !           590: 
        !           591: ; printret is like print yet it returns the value printed, this is used
        !           592: ; by pp                
        !           593: (def printret
        !           594:   (macro (*l*)
        !           595:         `(progn (print ,@(cdr *l*)) ,(cadr *l*))))
        !           596: 
        !           597: (def pp
        !           598:   (nlambda (*xlist*)
        !           599:        (prog (*outport* *cur* *fileopen* *prl* *atm*)
        !           600: 
        !           601:              (setq *outport* poport)                   ; default port
        !           602:              ; check if more to do, if not close output file if it is
        !           603:              ; open and leave
        !           604: 
        !           605: 
        !           606:    toploop    (cond ((null (setq *cur* (car *xlist*)))
        !           607:                     (condclosefile)
        !           608:                     (terpr)
        !           609:                     (return t)))
        !           610: 
        !           611:              (cond ((dtpr *cur*)
        !           612:                     (cond ((equal 'P (car *cur*))      ; specifying a port
        !           613:                            (condclosefile)             ; close file if open
        !           614:                            (setq *outport* (eval (cadr *cur*))))
        !           615: 
        !           616:                           ((equal 'F (car *cur*))      ; specifying a file
        !           617:                            (condclosefile)             ; close file if open
        !           618:                            (setq *outport* (outfile (cadr *cur*))
        !           619:                                  *fileopen* t))
        !           620: 
        !           621:                                                
        !           622:                           ((equal 'E (car *cur*))
        !           623:                            (eval (cadr *cur*)))
        !           624: 
        !           625:                           ( t (terpri *outport*)
        !           626:                               (*prpr *cur*)))  ;-DNC inserted
        !           627:                     (go botloop)))
        !           628: 
        !           629: 
        !           630:       (mapc (function
        !           631:               (lambda (prop)
        !           632:                       (prog (printer)
        !           633:                             (cond ((dtpr prop)
        !           634:                                    (setq printer (cdr prop))
        !           635:                                    (setq prop (car prop)))
        !           636:                                   ( t (setq printer 'pp-prop)))
        !           637:                             (cond ((eq 'value prop)
        !           638:                                    (cond ((boundp *cur*)
        !           639:                                           (apply printer
        !           640:                                                  (list *cur*
        !           641:                                                        (eval *cur*)
        !           642:                                                        'value)))))
        !           643:                                   ((eq 'function prop)
        !           644:                                    (cond ((and (getd *cur*)
        !           645:                                                (not (bcdp (getd *cur*))))
        !           646:                                           (apply printer
        !           647:                                                  (list *cur*
        !           648:                                                        (getd *cur*)
        !           649:                                                        'function)))))
        !           650:                                   ((get *cur* prop)
        !           651:                                    (apply printer
        !           652:                                           (list *cur*
        !           653:                                                 (get *cur* prop)
        !           654:                                                 prop)))))))
        !           655:            prettyprops)
        !           656: 
        !           657: 
        !           658:  botloop      (setq *xlist* (cdr *xlist*))
        !           659: 
        !           660:              (go toploop))))
        !           661: 
        !           662: ; moved to front.
        !           663: ;(setq pparm1 50 pparm2 100)
        !           664: 
        !           665: ;   -DNC These "prettyprinter parameters" are used to decide when we should
        !           666: ;      quit printing down the right margin and move back to the left -
        !           667: ;      Do it when the leftmargin > pparm1 and there are more than pparm2
        !           668: ;      more chars to print in the expression
        !           669: 
        !           670: ; cmu prefers dv instead of setq
        !           671: 
        !           672: #+cmu
        !           673: (def pp-value (lambda (i v p)
        !           674:                      (terpri *outport*) (*prpr (list 'dv i v))))
        !           675: 
        !           676: #-cmu
        !           677: (def pp-value (lambda (i v p)
        !           678:                      (terpr *outport*) (*prpr `(setq ,i ',v))))
        !           679: (def pp-function (lambda (i v p)
        !           680:                         (terpri *outport*) (*prpr (list 'def i v))))
        !           681: (def pp-prop (lambda (i v p)
        !           682:                     (terpri *outport*) (*prpr (list 'defprop i v p))))
        !           683: 
        !           684: (def condclosefile 
        !           685:   (lambda nil
        !           686:          (cond (*fileopen*
        !           687:                 (terpr *outport*)
        !           688:                 (close *outport*)
        !           689:                 (setq *fileopen* nil)))))
        !           690: 
        !           691: ;
        !           692: ; these routines are meant to be used by pp but since
        !           693: ; some people insist on using them we will set *outport* to nil
        !           694: ; as the default (moved to front).
        !           695: ;(setq *outport* nil)
        !           696: 
        !           697: 
        !           698: (def *prpr 
        !           699:   (lambda (x)
        !           700:          (cond ((not (boundp '*outport*)) (setq *outport* poport)))
        !           701:          (terpr *outport*)
        !           702:          (*prdf x 0 0)))
        !           703: 
        !           704: ; This is the principle addition for PEARL.
        !           705: ; SPRINT simply calls *prdf after filling in any missing parameters.
        !           706: (defun sprint (value &optional (lmar 0) (rmar 0))
        !           707:   (cond ((not (boundp '*outport*)) (setq *outport* poport)))
        !           708:   (*prdf value lmar rmar))
        !           709: 
        !           710: (defvar rmar)  ; -DNC this used to be m - I've tried to
        !           711:                ; to fix up the pretty printer a bit.  It
        !           712:                ; used to mess up regularly on (a b .c) types
        !           713:                ; of lists.  Also printmacros have been added.
        !           714: 
        !           715: 
        !           716: 
        !           717: ; Used to be $prdf but added a bit and changed to * to avoid
        !           718: ;   PEARL's history read macro $.
        !           719: (def *prdf
        !           720:   (lambda (l lmar rmar)
        !           721:     (prog (pmac)
        !           722: ;
        !           723: ;                      - DNC - Here we try to fix the tendency to print a
        !           724: ;                        thin column down the right margin by allowing it
        !           725: ;                        to move back to the left if necessary.
        !           726: ;
        !           727:          (cond ((and (>& lmar pparm1) (>& (flatc l (1+ pparm2)) pparm2))
        !           728:                 (terpri *outport*)
        !           729:                 (princ '"; <<<<< start back on the left <<<<<" *outport*)
        !           730:                 (*prdf l 5 0)
        !           731:                 (terpri *outport*)
        !           732:                 (princ '"; >>>>> continue on the right >>>>>" *outport*)
        !           733:                 (terpri *outport*)
        !           734:                 (return nil)))
        !           735:           (tab lmar *outport*)
        !           736:      a    (cond ((and (dtpr l)
        !           737:                       (atom (car l))
        !           738:                       (setq pmac (get (car l) 'printmacro))
        !           739:                      (cond ((stringp pmac)
        !           740:                             ; Added for PEARL (and UCI Lisp compatibility).
        !           741:                             ; a string printmacro means print this
        !           742:                             ;   string and then the cadr of l if
        !           743:                             ;   it's not nil, and only if l is
        !           744:                             ;   a one- or two-element list.
        !           745:                             (cond ((cddr l) ; more than two elements.
        !           746:                                    nil)
        !           747:                                   ((null (cdr l)) ; only one element.
        !           748:                                    (patom pmac)
        !           749:                                    t)
        !           750:                                   ( t (patom pmac)  ; two elements.
        !           751:                                       (patom (cadr l))
        !           752:                                       t)))
        !           753:                            ( t (apply pmac (list l lmar rmar)))))
        !           754:                 (return nil))
        !           755: ;
        !           756: ;                              -DNC - a printmacro is a lambda (l lmar rmar)
        !           757: ;                              attached to the atom.  If it returns nil then
        !           758: ;                              we assume it did not apply and we continue.
        !           759: ;                              Otherwise we assume it did the job.
        !           760: ;
        !           761:                 ((or (not (dtpr l))
        !           762: ;                    (*** at the moment we just punt hunks etc)
        !           763:                      (and (atom (car l)) (atom (cdr l))))
        !           764:                  (return (printret l *outport*)))
        !           765:                 ((<& (+ rmar (flatc l (chrct *outport*)))
        !           766:                         (chrct *outport*))
        !           767: ;
        !           768: ;      This is just a heuristic - if print can fit it in then figure that
        !           769: ;      the printmacros won't hurt.  Note that despite the pretentions there
        !           770: ;      is no guarantee that everything will fit in before rmar - for example
        !           771: ;      atoms (and now even hunks) are just blindly printed.    - DNC
        !           772: ;
        !           773:                  (printaccross l lmar rmar))
        !           774:                 ((and (*patom1 lpar)
        !           775:                       (atom (car l))
        !           776:                       (not (atom (cdr l)))
        !           777:                       (not (atom (cddr l))))
        !           778:                  (prog (c)
        !           779:                        (printret (car l) *outport*)
        !           780:                        (*patom1 '" ")
        !           781:                        (setq c (nwritn *outport*))
        !           782:                   a    (*prd1 (cdr l) c)
        !           783:                        (cond
        !           784:                         ((not (atom (cdr (setq l (cdr l)))))
        !           785:                          (terpr *outport*)
        !           786:                          (go a)))))
        !           787:                 (t
        !           788:                  (prog (c)
        !           789:                        (setq c (nwritn *outport*))
        !           790:                   a    (*prd1 l c)
        !           791:                        (cond
        !           792:                         ((not (atom (setq l (cdr l))))
        !           793:                          (terpr *outport*)
        !           794:                          (go a))))))
        !           795:      b    (*patom1 rpar))))
        !           796: 
        !           797: (def *prd1
        !           798:   (lambda (l n)
        !           799:     (prog nil
        !           800:           (*prdf (car l)
        !           801:                  n
        !           802:                  (cond ((null (setq l (cdr l))) (|1+| rmar))
        !           803:                        ((atom l) (setq n nil) (+ 4 rmar (pntlen l)))
        !           804:                        ( t rmar)))
        !           805:           (cond
        !           806:            ((null n) (*patom1 '" . ") (return (printret l *outport*))))
        !           807: ;         (*** setting n is pretty disgusting)
        !           808: ;         (*** the last arg to *prdf is the space needed for the suffix)
        !           809: ;              ;Note that this is still not really right - if the prefix
        !           810: ;              takes several lines one would like to use the old rmar 
        !           811: ;(             until the last line where the " . mumble)" goes.
        !           812:        )))
        !           813: 
        !           814: ; -DNC here's the printmacro for progs - it replaces some hackery that
        !           815: ; used to be in the guts of *prdf.
        !           816: 
        !           817: (def printprog
        !           818:   (lambda (l lmar rmar)
        !           819:     (prog (col)
        !           820:           (cond ((cdr (last l)) (return nil)))
        !           821:           (setq col (1+ lmar))
        !           822:           (princ '|(| *outport*)
        !           823:           (princ (car l) *outport*)
        !           824:           (princ '| | *outport*)
        !           825:           (print (cadr l) *outport*)
        !           826:           (mapc '(lambda (x)
        !           827:                         (cond ((atom x)
        !           828:                                (tab col *outport*)
        !           829:                                (print x *outport*))
        !           830:                           ( t (*prdf x (+ lmar 6) rmar))))
        !           831:                (cddr l))
        !           832:           (princ '|)| *outport*)
        !           833:           (return t))))
        !           834: 
        !           835: (putprop 'prog 'printprog 'printmacro)
        !           836: 
        !           837: ; Here's the printmacro for def.  The original *prdf had some special code
        !           838: ; for lambda and nlambda.
        !           839: 
        !           840: (def printdef
        !           841:   (lambda (l lmar rmar)
        !           842:     (cond ((and (\=& 0 lmar)           ; only if we're really printing a defn
        !           843:                 (\=& 0 rmar)
        !           844:                 (cadr l)
        !           845:                 (atom (cadr l))
        !           846:                 (caddr l)
        !           847:                 (null (cdddr l))
        !           848:                 (memq (caaddr l) '(lambda nlambda macro lexpr))
        !           849:                 (null (cdr (last (caddr l)))))
        !           850:            (princ '|(| *outport*)
        !           851:            (princ 'def *outport*)
        !           852:            (princ '| | *outport*)
        !           853:            (princ (cadr l) *outport*)
        !           854:            (terpri *outport*)
        !           855:            (princ '|  (| *outport*)
        !           856:            (princ (caaddr l) *outport*)
        !           857:            (princ '| | *outport*)
        !           858:            (princ (cadaddr l) *outport*)
        !           859:            (terpri *outport*)
        !           860:            (mapc  '(lambda (x) (*prdf x 4 0)) (cddaddr l))
        !           861:            (princ '|))| *outport*)
        !           862:            t))))
        !           863: 
        !           864: (putprop 'def 'printdef 'printmacro)
        !           865: 
        !           866: ; There's a version of this hacked into the printer (where it don't belong!)
        !           867: ; Note that it must NOT apply to things like (quote a b).
        !           868: 
        !           869: (def printquote
        !           870:   (lambda (l lmar rmar)
        !           871:     (cond ((or (null (cdr l)) (cddr l)) nil)
        !           872:           ( t (princ '|'| *outport*) 
        !           873:              (*prdf (cadr l) (1+ lmar) rmar)
        !           874:              t))))
        !           875: 
        !           876: (putprop 'quote 'printquote 'printmacro)
        !           877: 
        !           878: 
        !           879: 
        !           880: 
        !           881: (def printaccross
        !           882:   (lambda (l lmar rmar)
        !           883:     (prog nil
        !           884: ;         (*** this is needed to make sure the printmacros are executed)
        !           885:           (princ '|(| *outport*)  ;)
        !           886:      l:   (cond ((null l))
        !           887:                 ((atom l) (princ '|. | *outport*) (princ l *outport*))
        !           888:                 ( t (*prdf (car l) (nwritn *outport*) rmar)
        !           889:                    (setq l (cdr l))
        !           890:                    (cond (l (princ '| | *outport*)))
        !           891:                    (go l:))))))
        !           892: 
        !           893: 
        !           894: 
        !           895: (def tab (lexpr (n)
        !           896:   (prog (nn prt) (setq nn (arg 1))
        !           897:                (cond ((>& n 1) (setq prt (arg 2))))
        !           898:                (cond ((>& (nwritn prt) nn) (terpri prt)))
        !           899:                (printblanks (- nn (nwritn prt)) prt))))
        !           900: 
        !           901: ; ========================================
        !           902: ;
        !           903: ;      (charcnt port) 
        !           904: ; returns the number of characters left on the current line
        !           905: ; on the given port
        !           906: ;
        !           907: ; =======================================
        !           908: 
        !           909: 
        !           910: (def charcnt
        !           911:      (lambda (port) (- linel (nwritn port))))
        !           912: 
        !           913: (putd 'chrct (getd 'charcnt))
        !           914: 
        !           915: (def *patom1 (lambda (x) (patom x *outport*)))
        !           916: 
        !           917: ; vi: set lisp:

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