Return to complra.l CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / liszt

Annotation of 3BSD/cmd/liszt/complra.l, revision 1.1

1.1     ! root        1: ;--- file: complra.l
        !             2: (include "compmacs.l")
        !             3: 
        !             4: (def put 
        !             5:   (macro (x)
        !             6:         ((lambda (atm prp arg)
        !             7:                  `(progn (putprop ,atm ,arg ,prp) ,atm))
        !             8:          (cadr x) (caddr x) (cadddr x))))
        !             9: 
        !            10: 
        !            11: 
        !            12: ; register allocation and important addresses for compiled code
        !            13: ;
        !            14: (setq np-reg     'r6           ;points one beyond top stack value
        !            15:       lbot-reg   'r7           ;current value of lbot
        !            16:       ln-reg     'r8           ;address of linker
        !            17:       olbot-reg  'r10          ;base of args to this fcn
        !            18:       bnp-reg   'r11           ;bind np
        !            19:       bnp-val    '"*-32(r8)"   ;value of global var bnp
        !            20:       i-mov      'movl         ;stacking instruction for namestack
        !            21:       i-clr     'clrl          ;clear namestack
        !            22:       qfuncl    '"*-28(r8)"    ;addr of qfuncl
        !            23:       )
        !            24: 
        !            25: ; these are the short cut places to call when you want to call
        !            26: ; a non system function with 4 or less arguments
        !            27: 
        !            28: (setplist 'qfs '(0 "*-8(r8)"   1 "*-12(r8)"   2 "*-16(r8)"
        !            29:                 3 "*-20(r8)"  4 "*-24(r8)"))
        !            30: 
        !            31: (setq faslflag nil)
        !            32: 
        !            33: (declare (special w-vars w-labs w-ret w-name w-bv w-atmt cm-alv v-cnt))
        !            34: 
        !            35: 
        !            36: 
        !            37: 
        !            38: (cond ((lessp (opval 'pagelimit) 2000) (opval 'pagelimit 2000)))
        !            39: 
        !            40: 
        !            41: 
        !            42: (def Gensym (lambda (x)
        !            43:        (prog (e)
        !            44:                (setq e (gensym (cond (x) (t 'L))))
        !            45:                (setq twa-list (cons e twa-list))
        !            46:                (return e))))
        !            47: 
        !            48: (def cvt (lambda (a)
        !            49:        (prog (l)
        !            50:                (setq l (quotient a 2704))
        !            51:                (setq a (difference a (times l 2704)))
        !            52:                (setq l (list l (quotient a 52) (mod a 52)))
        !            53:                (return (mapcar '(lambda (x) (nthelem
        !            54:                        (add1 x)
        !            55:                        '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
        !            56:                          a b c d e f g h i j k l m n o p q r s t u v w x y z))) l)))))
        !            57: 
        !            58: (def nth
        !            59:   (lambda (x n)
        !            60:          (cond ((equal n 0) x)
        !            61:                ((lessp n 0)
        !            62:                 (prog (m lst)
        !            63:                       (setq m (difference 0 n))
        !            64:                       (setq x (reverse x))
        !            65:                    lp (cond ((zerop m) (return lst)))
        !            66:                       (setq lst (cons (car x) lst))
        !            67:                       (setq x (cdr x))
        !            68:                       (setq m (sub1 m))
        !            69:                       (go lp)))
        !            70:                (t (nth (cdr x) (sub1 n))))))
        !            71: 
        !            72: (def cleanup (lambda nil
        !            73:                     (mapc 'rematom twa-list)
        !            74:                     (setq twa-list nil)))
        !            75: 
        !            76: (def mylogor (lambda (x y)
        !            77:                   (boole 7 x y)))
        !            78: 
        !            79: (def leftshift 
        !            80:   (lambda (x cnt)
        !            81:          (prog ()
        !            82:        loop   (cond ((zerop cnt) (return x))
        !            83:                     ((lessp cnt 0) 
        !            84:                      (setq x (quotient x 2))
        !            85:                      (setq cnt (add1 cnt)))
        !            86:                     (t (setq x (times x 2)) (setq cnt (sub1 cnt))))
        !            87:                (go loop))))
        !            88: 
        !            89: (def flag 
        !            90:   (lambda (atm flg)
        !            91:        (cond ((put atm flg t) atm))))
        !            92: 
        !            93: (def ifflag 
        !            94:   (lambda (atm flg)
        !            95:          (cond ((and (and (atom atm) (not (numberp atm))) 
        !            96:                      (get atm flg)) 
        !            97:                 t))))
        !            98: 
        !            99: (def unflag 
        !           100:   (lambda (atm flg)
        !           101:        (put atm flg nil)))
        !           102: 
        !           103: 
        !           104: 
        !           105: ;--- chain - a : an atom
        !           106: ;      returns a if a has the form cxr where x is an elt of {a d}
        !           107: ;      else returns nil.
        !           108: ;
        !           109: (def chain 
        !           110:   (lambda (a)
        !           111:          (prog (expl)
        !           112:                (cond ((lessp (flatsize a) 3) (return nil)))
        !           113:                (setq expl (explode a))
        !           114:                (cond ((not (eq (car expl) 'c)) (return nil)))
        !           115:        loop    (setq expl (cdr expl))
        !           116:                (cond ((eq (car expl) 'a) (go loop))
        !           117:                      ((eq (car expl) 'd) (go loop))
        !           118:                      ((and (eq (car expl) 'r) (null (cdr expl))) (return a))
        !           119:                      (t (return nil))))))
        !           120:                
        !           121: ;--- ismacro - a : atom name found in the functional position
        !           122: ;      returns the body of the macro if a is the name of a macro, else
        !           123: ;      return nil.
        !           124: ;
        !           125: (def ismacro 
        !           126:   (lambda (a)
        !           127:          (prog (x)
        !           128:                (cond ((not (symbolp a)) (return nil))
        !           129:                      ((setq x (assoc a k-macros)) (return (cadr x))))
        !           130:                (setq x (getd a))
        !           131:                (cond ((and (bcdp x) (eq (getdisc x) 'macro)) (return x))
        !           132:                      ((and (dtpr x) (eq (car x) 'macro)) (return x))))))
        !           133: 
        !           134: ;--- isnlam - a : atom found in the functional position
        !           135: ;      return the body of the nlambda if a names an nlambda,
        !           136: ;      else return nil
        !           137: ;
        !           138: (def isnlam 
        !           139:   (lambda (a)
        !           140:          (prog (x)
        !           141:                (cond ((not (symbolp a)) (return nil)))
        !           142:                (cond ((setq x (assoc a k-nlams)) (return (cadr x))))
        !           143:                (setq x (getd a))
        !           144:                (cond ((and (dtpr x) (eq (car x) 'nlambda)) (return x))
        !           145:                      ((and (bcdp x) (eq (getdisc x) 'nlambda)) (return x))))))
        !           146: 
        !           147: (def ucar 
        !           148:   (lambda (arg)
        !           149:          (cond ((dtpr arg) (car arg))
        !           150:                ((numberp arg) arg)
        !           151:                ((getd arg) arg)
        !           152:                (t (get arg '*car)))))
        !           153: 
        !           154: ;--- defsysf - funname : lisp function name
        !           155: ;           - inname  : internal system name
        !           156: ;      We declare that funname is a system type function with
        !           157: ;      the address of the c-code for it at inname.  Thus we
        !           158: ;      can call this function directly without going through
        !           159: ;      the oblist.  This type of optimization can be turned off
        !           160: ;      by disabling this routine (if debuggin is desired)
        !           161: ;
        !           162: (def defsysf
        !           163:   (lambda (funname inname)
        !           164:          (putprop funname inname 'x-sysf)))    ; indicate of prop list
        !           165: 
        !           166: (def $pr$ 
        !           167:   (macro (x)
        !           168:        (list 'patom (cadr x) 'vp-sfile)))
        !           169: 
        !           170: (def emit1 
        !           171:   (lambda (a)
        !           172:        (aprint a)
        !           173:        ($terpri)))
        !           174: 
        !           175: (def emit2 
        !           176:   (lambda (a b)
        !           177:        (aprint a)
        !           178:        ($pr$ '" ")
        !           179:        (aprint b)
        !           180:        ($terpri)))
        !           181: 
        !           182: (def emit3 
        !           183:   (lambda (a b c)
        !           184:        (aprint a)
        !           185:        ($pr$ '" ")
        !           186:        (aprint b)
        !           187:        ($pr$ '\,)
        !           188:        (aprint c)
        !           189:        ($terpri)))
        !           190: 
        !           191: (def emit4 
        !           192:   (lambda (a b c d)
        !           193:          (aprint a)
        !           194:          ($pr$ '" ")
        !           195:          (aprint b)
        !           196:          ($pr$ '\,)
        !           197:          (aprint c)
        !           198:          ($pr$ '\,)
        !           199:          (aprint d)
        !           200:          ($terpri)))
        !           201: 
        !           202: (def aprint 
        !           203:   (lambda (foo)
        !           204:          (prog nil
        !           205:                loop (cond ((null foo) (return))
        !           206:                           ((atom foo) ($pr$ foo) (return))
        !           207:                           (t ($pr$ (car foo))
        !           208:                              (setq foo (cdr foo))))
        !           209:                (go loop))))
        !           210:                
        !           211: (def $terpri (lambda () (terpr vp-sfile)))
        !           212: 

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