Return to complrc.l CVS log

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

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

1.1     ! root        1: ;--- file : complrc.l
        !             2: (include "compmacs.l")
        !             3: 
        !             4: (declare (special w-vars w-labs w-ret w-name w-bv w-atmt cm-alv v-cnt))
        !             5: (def $pr$ (macro (x) `(patom ,(cadr x) compout)))
        !             6: 
        !             7: (def put 
        !             8:   (macro (x)
        !             9:         ((lambda (atm prp arg)
        !            10:                  `(progn (putprop ,atm ,arg ,prp) ,atm))
        !            11:          (cadr x) (caddr x) (cadddr x))))
        !            12: 
        !            13: (def f-if 
        !            14:   (lambda (v-l v-r v-j v-t) 
        !            15:          (cond ((eq (caar v-l) 't) 
        !            16:                 (cond ((null (cdar v-l)) (f-exp t v-r v-t)) 
        !            17:                       (t (f-seq (cdar v-l) v-r v-t)))) 
        !            18:                (t (prog (v-tr v-i v-dv) 
        !            19:                         (setq v-tr (f-reg nil))
        !            20:                         (setq v-dv 'amb)
        !            21:                         (cond ((null (cdr v-l)) 
        !            22:                                (setq v-tr v-r) 
        !            23:                                (cond ((null (cdar v-l)) (go loop2))) 
        !            24:                                (setq v-dv nil) 
        !            25:                                (setq v-i (cadr v-j))) 
        !            26:                               ((null (cdar v-l)) 
        !            27:                                (setq v-tr v-r) 
        !            28:                                (setq v-t (f-if (cdr v-l) v-r v-j v-t)) 
        !            29:                                (setq v-t (f-addi (list 'true (cadr v-j) t)
        !            30:                                                  v-t))
        !            31:                                (go loop1)) 
        !            32:                               (t (setq v-t (f-leap (f-if (cdr v-l)
        !            33:                                                          v-r 
        !            34:                                                          v-j 
        !            35:                                                          v-t))) 
        !            36:                                  (setq v-t (f-addi v-j v-t)) 
        !            37:                                  (setq v-i (cadr s-inst)))) 
        !            38:                         (setq v-t (f-seq (cdar v-l) v-r v-t)) 
        !            39:                         (setq v-t (f-addi (list 'false v-i v-dv) v-t)) 
        !            40:                 loop1 
        !            41:                         (setq v-t (f-addi (list 'minus (f-use v-tr) nil) v-t)) 
        !            42:                 loop2 
        !            43:                         (return (f-exp (caar v-l) v-tr v-t))))))) 
        !            44: ;--- f-seqp - v-l : sequence of s-expressions and labels to evaluate
        !            45: ;          - v-r : psreg in which to store the final result
        !            46: ;          - v-t : tail.
        !            47: ;      This will do the top level of prog bodies 
        !            48: ;
        !            49: (def f-seqp 
        !            50:   (lambda (v-l v-r v-t) 
        !            51:          (do ((l (reverse v-l) (cdr l))
        !            52:               (newreg v-r)
        !            53:               (reg v-r newreg))
        !            54:              ((null l) v-t)
        !            55:              (cond ((symbolp (car l))
        !            56:                     (setq v-t (f-labl v-t (car l))))
        !            57:                    (t (setq v-t (f-exp (car l) reg v-t))
        !            58:                       (setq newreg (Gensym nil)))))))
        !            59: 
        !            60: ;--- f-seq - v-l : sequence of s-expressions to evaluate
        !            61: ;         - v-r : psreg in which to store the final result
        !            62: ;         - v-t : tail
        !            63: ;
        !            64: ;      This generates intermediate codes to calculate the s-expressions
        !            65: ;      in v-l.  This does not look for labels.
        !            66: ;
        !            67: (def f-seq
        !            68:   (lambda (v-l v-r v-t)
        !            69:          (do ((l (reverse v-l) (cdr l))
        !            70:               (reg v-r (Gensym nil)))
        !            71:              ((null l) v-t)
        !            72:              (setq v-t (f-exp (car l) reg v-t)))))
        !            73: 
        !            74: ;--- f-pusha - v-l : list of forms to evaluate and push on stack
        !            75: ;           - v-r : register to place result of last expr in 
        !            76: ;           - v-t : tail
        !            77: ;      emits code to to evaluate and push forms on the stack.
        !            78: (def f-pusha
        !            79:   (lambda (v-l v-r v-t)
        !            80:          (cond ((null v-l) v-t) 
        !            81:                (t (do ((ll (reverse v-l) (cdr ll)) 
        !            82:                        (reg v-r (Gensym nil))
        !            83:                        (res v-t
        !            84:                             (f-exp (car ll) 
        !            85:                                    reg
        !            86:                                    (f-addi `(push ,(f-use reg)) res))))
        !            87:                       ((null ll) res))))))
        !            88: 
        !            89: ;--- f-iter - v-e : list of expression to evaluate
        !            90: ;          - v-v : list of variables those expressions will be bound to
        !            91: ;      This checks of the given expressions can be bound to the given
        !            92: ;      variables with no conflicts.  This is determining if tail
        !            93: ;      merging is possible were we replace recursion by iteration.
        !            94: ;
        !            95: (def f-iter
        !            96:   (lambda (v-e v-v) 
        !            97:          (prog (v-y w-vars) 
        !            98: 
        !            99:          loop 
        !           100:                (cond ((null v-e) (return t)) 
        !           101:                      ((null v-v) (go bad)) 
        !           102:                      ((ifflag (setq v-y (car v-v)) x-spec) (go bad)) 
        !           103:                      ((equal (car v-e) v-y) (go usable))
        !           104:                      (t (go check)))
        !           105:          next 
        !           106:                (setq w-vars (cons v-y w-vars)) 
        !           107:          usable 
        !           108:                (setq v-e (cdr v-e)) 
        !           109:                (setq v-v (cdr v-v)) 
        !           110:                (go loop) 
        !           111:          check 
        !           112:                (cond ((f-nice (car v-e)) (go next))) 
        !           113:          bad 
        !           114:                (return nil)))) 
        !           115: 
        !           116: (def f-nice 
        !           117:   (lambda (v-e)
        !           118:          (cond ((atom v-e) (not (member v-e w-vars))) 
        !           119:                ((atom (car v-e)) 
        !           120:                 (cond ((eq (car v-e) 'quote) t) 
        !           121:                       ((ifflag (car v-e) x-dont) nil) 
        !           122:                       (t (f-all v-e 'f-nice)))) 
        !           123:                (t (f-all v-e 'f-nice))))) 
        !           124: 
        !           125: ;--- f-all - v-l : list
        !           126: ;         - v-f : function
        !           127: ;      mapc function v-f over v-l as long as the result is non nil
        !           128: ;
        !           129: (def f-all 
        !           130:   (lambda (v-l v-f) 
        !           131:          (cond ((null v-l) t) 
        !           132:                ((funcall v-f (car v-l)) (f-all (cdr v-l) v-f)) 
        !           133:                (t nil)))) 
        !           134: 
        !           135: (def f-make 
        !           136:   (lambda (v-r v-v) 
        !           137:          (put v-r x-reg v-v))) 
        !           138: 
        !           139: ;--- f-leap - v-t : tail
        !           140: ;      We generate and place in global variable s-inst an itermediate
        !           141: ;      instructin which will jump to the current top location in v-t.
        !           142: ;      If there is not a label on top of v-t, one is added.
        !           143: ;
        !           144: (def f-leap 
        !           145:   (lambda (v-t) 
        !           146:          (cond ((not (setq s-inst (get (caar v-t) x-leap))) 
        !           147:                 (setq v-t (f-labl v-t nil)) 
        !           148:                 (setq s-inst 'go))) 
        !           149:          (setq s-inst (list s-inst (cadar v-t))) 
        !           150:          v-t)) 
        !           151: 
        !           152: ;--- f-labl - v-t : tail
        !           153: ;          - v-l : real label or nil
        !           154: ;      We insure that there is a label on top of v-t. If not we
        !           155: ;      create one. If we are given a label, we associate it with
        !           156: ;      a created label. 
        !           157: ;      Labels in v-t are all gensymed and the association is all
        !           158: ;      on the property list of the value of w-labs.
        !           159: ; Errors: duplicate labels
        !           160: ;
        !           161: (def f-labl 
        !           162:   (lambda (v-t v-l) 
        !           163:          (prog (v-i) 
        !           164:                (cond ((eq (caar v-t) 'label) 
        !           165:                       (cond (v-l (cond ((setq v-i (get w-labs v-l)))
        !           166:                                        (t (put w-labs v-l (cadar v-t))
        !           167:                                           (return v-t))))
        !           168:                             (t (return v-t)))) 
        !           169:                      
        !           170:                      ((null v-l) (setq v-i (Gensym nil))) 
        !           171:                      ((setq v-i (get w-labs v-l))) 
        !           172:                      (t (put w-labs v-l (setq v-i (Gensym nil))))) 
        !           173:                (return (f-addi (list 'label v-i) v-t))))) 
        !           174: 
        !           175: (def f-test 
        !           176:   (lambda (v-t) 
        !           177:          (and (eq (caar v-t) 'minus) 
        !           178:               (null (caddar v-t))))) 
        !           179: 
        !           180: (def f-vble 
        !           181:   (lambda (v-v v-r) 
        !           182:          (f-use v-r) 
        !           183:          (cond ((not (symbolp v-v)) v-v) 
        !           184:                ((null v-v) nil)
        !           185:                ((f-con v-v) v-v) 
        !           186:                ((ifflag v-v x-spec) v-v) 
        !           187:                ((member v-v w-vars) v-v) 
        !           188:                (t (setq k-free (cons v-v k-free)) 
        !           189:                   (flag v-v x-spec))))) 
        !           190: 
        !           191: (def f-addi 
        !           192:   (lambda (v-i v-t) 
        !           193:          (prog (v-o) 
        !           194:                (cond ((not (setq v-o (get (car v-i) x-opt))) (go normal)) 
        !           195:                      ((setq v-o (funcall v-o  v-i v-t)) (return v-o)))
        !           196:           normal 
        !           197:                (return (cons v-i v-t))))) 
        !           198: 
        !           199: (def f-reg 
        !           200:   (lambda (v-f) 
        !           201:          (cond ((numberp v-f) (put (Gensym nil) x-reg v-f)) 
        !           202:                (v-f (flag (Gensym nil) v-f)) 
        !           203:                (t (Gensym nil))))) 
        !           204: 
        !           205: (def f-con 
        !           206:   (lambda (v-v) 
        !           207:          (cond ((ifflag v-v x-spec) nil)
        !           208:                (t (ifflag v-v x-con)))))
        !           209: 
        !           210: (def f-one 
        !           211:   (lambda (v-e) 
        !           212:          (or (atom v-e) 
        !           213:              (eq (car v-e) 'quote)))) 
        !           214: 
        !           215: (def f-swap 
        !           216:   (lambda (v-t) 
        !           217:          (cond ((eq (caar v-t) 'get) (f-swap (cdr v-t))) 
        !           218:                (t (rplaca (car v-t) 
        !           219:                           (cond ((eq (caar v-t) 'true) 'false) 
        !           220:                                 (t 'true))))) 
        !           221:          v-t)) 
        !           222: 
        !           223: (def f-xval 
        !           224:   (lambda (v-t v-r) 
        !           225:          (cond ((or (eq (caar v-t) 'get) 
        !           226:                     (eq (caddar v-t) 'amb)) v-t) 
        !           227:                (t (f-addi (list 'get (f-use v-r) (caddar v-t)) v-t))))) 
        !           228: 
        !           229: ;--- f-use - v-r :  psreg whose value is being used
        !           230: ;      we keep track of the number of times the value of a register is
        !           231: ;      used,  the count is kept under the indicator x-count in the
        !           232: ;      psreg's property list.  the count starts at nil, goes to `used'
        !           233: ;      and then to `force'.  Once the count goes to `force' all gets
        !           234: ;      must be done. when the count is used get should look to see
        !           235: ;      if the following intermediate code instruction is the one
        !           236: ;      using the register and in that case it can merge with that
        !           237: ;      instruction
        !           238: ;
        !           239: (def f-use
        !           240:   (lambda (v-r)
        !           241:          ((lambda (curv)
        !           242:                   (cond (curv (cond ((not (eq curv 'force)) 
        !           243:                                      (putprop v-r 'force 'x-count))))
        !           244:                         (t (putprop v-r 'used 'x-count)))
        !           245:                   v-r)
        !           246:           (get v-r 'x-count))))
        !           247: 
        !           248: 
        !           249: (def f-chop 
        !           250:   (lambda (v-t) 
        !           251:          (cond ((or (eq (caar v-t) 'label) 
        !           252:                     (eq (caar v-t) 'end)) v-t) 
        !           253:                (t (f-chop (cdr v-t)))))) 
        !           254: 
        !           255: (def f-tfo 
        !           256:   (lambda (v-i v-t) 
        !           257:          (cond ((not (f-like v-t '(go label))) nil) 
        !           258:                ((not (equal (cadr v-i) (cadadr v-t))) nil) 
        !           259:                (t (rplaca (cdr v-i) (cadar v-t)) 
        !           260:                   (f-swap (rplaca v-t v-i)))))) 
        !           261: 
        !           262: (def f-like 
        !           263:   (lambda (v-t v-p) 
        !           264:          (cond ((null v-p) t) 
        !           265:                ((null v-t) nil) 
        !           266:                ((equal (caar v-t) (car v-p)) (f-like (cdr v-t) (cdr v-p))) 
        !           267:                (t nil)))) 
        !           268: 
        !           269: (def f-aor 
        !           270:   (lambda (v-l v-e v-r v-t) 
        !           271:          (cond ((null v-l) 
        !           272:                 (f-addi (list 'get (f-use v-r) (eq v-e 'and)) v-t)) 
        !           273:                (t (prog (v-j v-dv v-tr v-tr2) 
        !           274:                         (setq v-dv (eq v-e 'or))
        !           275:                         (setq v-tr v-r)
        !           276:                         (setq v-tr2 v-r)
        !           277:                         (setq v-e 
        !           278:                               (cond ((eq v-e 'and) 'false) 
        !           279:                                     (t 'true))) 
        !           280:                         (setq v-l (reverse v-l)) 
        !           281:                         (cond ((null (cdr v-l)) (go loop)) 
        !           282:                               ((and (f-test v-t) 
        !           283:                                     (not (eq (caadr v-t) 'get))) 
        !           284:                                (cond ((eq (caddadr v-t) 'amb) 
        !           285:                                       (setq v-dv 'amb) 
        !           286:                                       (setq v-tr2 (f-reg nil))) 
        !           287:                                      ((not (equal (caddadr v-t) v-dv)) 
        !           288:                                       (setq v-dv 'amb))) 
        !           289:                                (cond ((equal (caadr v-t) v-e) 
        !           290:                                       (setq v-j (cadadr v-t)) 
        !           291:                                       (go loop))) 
        !           292:                                (rplacd (cdr v-t) (f-leap (cddr v-t)))) 
        !           293:                               (t (setq v-t (f-leap v-t)))) 
        !           294:                         (setq v-j (cadr s-inst)) 
        !           295:                  loop 
        !           296:                         (setq v-t (f-exp (car v-l) v-tr v-t)) 
        !           297:                         (setq v-tr v-tr2) 
        !           298:                         (cond ((null (setq v-l (cdr v-l))) (return v-t))) 
        !           299:                         (setq v-t (f-addi (list v-e v-j v-dv) v-t)) 
        !           300:                         (setq v-t (f-addi (list 'minus (f-use v-tr) nil) v-t)) 
        !           301:                         (go loop)))))) 
        !           302: 
        !           303: (def f-repl 
        !           304:   (lambda (v-e) 
        !           305:          (cons (ucar (car v-e)) (cdr v-e)))) 
        !           306: 
        !           307: ;this seems out of date, must change to mapconvert
        !           308: (def f-domap
        !           309:   (lambda (v-e) 
        !           310:          (prog (v-x) 
        !           311:                (cond ((setq v-x (f-chkf (cadr v-e) 4)) 
        !           312:                       (return (list (car v-e) 
        !           313:                                     (list 'quote v-x)
        !           314:                                     (caddr v-e)))) 
        !           315:                      (t (return v-e))))))
        !           316: 
        !           317: 
        !           318: ;--- mapconvert - access : function to access parts of lists
        !           319: ;              - join   : function to join results
        !           320: ;              - resu   : function to apply to result
        !           321: ;              - form   : mapping form
        !           322: ;      This function converts maps to an equivalent do form.
        !           323: ;
        !           324: (def mapconvert
        !           325:   (lambda (access join resu form )
        !           326:          (prog (vrbls finvar acc accform compform tmp)
        !           327: 
        !           328:                (setq finvar (Gensym 'X)   ; holds result
        !           329: 
        !           330:                      vrbls (maplist '(lambda (arg)
        !           331:                                        ((lambda (temp)
        !           332:                                            (cond ((or resu (cdr arg))
        !           333:                                                   `(,temp ,(car arg)
        !           334:                                                           (cdr ,temp)))
        !           335:                                                  (t `(,temp 
        !           336:                                                       (setq ,finvar ,(car arg))
        !           337:                                                       (cdr ,temp)))))
        !           338:                                         (Gensym 'X)))
        !           339:                                    (cdr form))
        !           340: 
        !           341: 
        !           342:                      acc (mapcar '(lambda (tem)
        !           343:                                           (cond (access `(,access ,(car tem)))
        !           344:                                                 (t (car tem))))
        !           345:                                  vrbls)
        !           346: 
        !           347:                      accform (cond ((or (atom (setq tmp (car form)))
        !           348:                                         (null (setq tmp (cmacroexpand tmp)))
        !           349:                                         (not (member (car tmp) '(quote function))))
        !           350:                                     `(funcall ,tmp ,@acc))
        !           351:                                    (t `(,(cadr tmp) ,@acc))))
        !           352:                (return
        !           353:                 `((lambda (,finvar)
        !           354:                    (do ( ,@vrbls)
        !           355:                        ((null ,(caar vrbls)))
        !           356:                        ,(cond (join `(setq ,finvar (,join ,accform ,finvar)))
        !           357:                               (t accform)))
        !           358:                    ,(cond (resu `(,resu ,finvar))
        !           359:                           (t finvar)))
        !           360:                   nil )))))
        !           361: (putprop 'mapc 'f-mapc 'x-spfm)
        !           362: (def f-mapc
        !           363:   (lambda (v-e)
        !           364:          (mapconvert 'car nil nil (cdr v-e))))
        !           365: 
        !           366: (putprop 'mapcar 'f-mapcar 'x-spfm)
        !           367: (def f-mapcar
        !           368:   (lambda (v-e)
        !           369:          (mapconvert 'car 'cons 'reverse (cdr v-e))))
        !           370: 
        !           371: (putprop 'map 'f-map 'x-spfm)
        !           372: (def f-map
        !           373:   (lambda (v-e)
        !           374:          (mapconvert nil nil nil (cdr v-e))))
        !           375: 
        !           376: 
        !           377: (putprop 'maplist 'f-maplist 'x-spfm)
        !           378: (def f-maplist
        !           379:   (lambda (v-e)
        !           380:          (mapconvert nil 'cons 'reverse (cdr v-e))))
        !           381: 
        !           382: 
        !           383: 
        !           384: 
        !           385: (def f-initv
        !           386:   (lambda (v-l)
        !           387:          (mapcar 'car (car v-l))))
        !           388: 
        !           389: (def f-inits
        !           390:   (lambda (v-l)
        !           391:          (mapcar 'cadr (car v-l))))
        !           392: 
        !           393: (def f-repv
        !           394:   (lambda (v-l)
        !           395:          (prog (v-x)
        !           396:                (setq v-l (car v-l))
        !           397:           lp 
        !           398:                (cond ((null v-l) (return (reverse v-x))))
        !           399:                (cond ((cddar v-l) (setq v-x (cons (caar v-l) v-x))))
        !           400:                (setq v-l (cdr v-l))
        !           401:                (go lp))))
        !           402: 
        !           403: (def f-reps
        !           404:   (lambda (v-l)
        !           405:          (prog (v-x v-y)
        !           406:                (setq v-l (car v-l))
        !           407:           lp 
        !           408:                (cond ((null v-l) (return (reverse v-x))))
        !           409:                (cond ((cddar v-l) 
        !           410:                       (setq v-y (caddar v-l)) (setq v-x (cons v-y v-x))))
        !           411:                (setq v-l (cdr v-l))
        !           412:                (go lp))))
        !           413: 
        !           414: (def f-endtest
        !           415:   (lambda (v-l)
        !           416:          (caadr v-l)))
        !           417: 
        !           418: (def f-endbody
        !           419:   (lambda (v-l)
        !           420:          (cdadr v-l)))
        !           421: 
        !           422: (def f-dobody
        !           423:   (lambda (v-l)
        !           424:          (cddr v-l)))
        !           425: 
        !           426: 
        !           427: (putprop 'do 'f-do 'x-spf)
        !           428: 
        !           429: (def f-do
        !           430:   (lambda (v-l v-r v-t)
        !           431:     (prog (v-init v-initv v-rep v-repv v-loop v-outl v-retl)
        !           432:        (cond ((and (car v-l) (atom (car v-l))) ; look for old do
        !           433:               (setq v-l (olddo-to-newdo v-l))))
        !           434:        (setq v-initv (f-initv v-l)
        !           435:              v-init (f-inits v-l)
        !           436:              v-repv (f-repv v-l)
        !           437:              v-rep (f-reps v-l)
        !           438:              v-retl (Gensym nil)
        !           439:              v-loop (Gensym nil)
        !           440:              v-outl (Gensym nil))
        !           441:        (w-save)
        !           442:        (return
        !           443:         (f-pusha v-init v-r
        !           444:            (prog (w-ret w-labs tmp)
        !           445:                  (setq w-ret `(,v-r . (go ,v-retl)))
        !           446:                  (setq w-labs (Gensym nil))
        !           447:                  (setq tmp 
        !           448:                   `((begin ,(length v-initv))
        !           449:                     ,@(mapcar '(lambda (arg) (setq w-locs
        !           450:                                                           (cons arg w-locs))
        !           451:                                             `(bind ,arg))
        !           452:                               v-initv)
        !           453:                     (label ,v-loop)
        !           454:                     ,@(f-exp (f-endtest v-l) v-r
        !           455:                              `((minus ,v-r nil)
        !           456:                                (true ,v-outl nil)
        !           457:                                ,@(f-seqp (f-dobody v-l) v-r
        !           458:                                          (f-pusha v-rep v-r
        !           459:                                              `((dopop ,v-repv)
        !           460:                                                (go ,v-loop)
        !           461:                                                (label ,v-outl)
        !           462:                                                ,@(f-seq (f-endbody v-l) v-r
        !           463:                                                         `((end ,v-retl)
        !           464:                                                           ,@v-t)))))))))
        !           465:                  (w-unsave)
        !           466:                  (return tmp)))))))
        !           467: 
        !           468: (def olddo-to-newdo
        !           469:   (lambda (v-l)
        !           470:          `(((,(car v-l) ,(cadr v-l) ,(caddr v-l)))
        !           471:            (,(cadddr v-l) nil)
        !           472:            ,@(cddddr v-l))))
        !           473: 
        !           474: (putprop 'cond 'f-cond 'x-spf)
        !           475: 
        !           476: (def f-cond    
        !           477:   (lambda (v-l v-r v-t) 
        !           478:          (setq v-t (f-leap v-t)) 
        !           479:          (f-if v-l v-r s-inst v-t))) 
        !           480: 
        !           481: (putprop 'quote 'f-quote 'x-spf)
        !           482: 
        !           483: (def f-quote 
        !           484:   (lambda (v-l v-r v-t) 
        !           485:         (f-addi (list 'get v-r (cons 'quote v-l)) v-t))) 
        !           486: 
        !           487: (putprop 'prog 'f-prog 'x-spf)
        !           488: 
        !           489: 
        !           490: 
        !           491: 
        !           492: (putprop 'setq 'f-setq 'x-spf)
        !           493: 
        !           494: (def f-setq 
        !           495:   (lambda (v-l v-r v-t)
        !           496:          (cond ((null (car v-l)) v-t))
        !           497:          (do ((ll (reverse v-l) (cddr ll))
        !           498:               (reg v-r (Gensym nil)))
        !           499:              ((null ll) v-t)
        !           500:              (setq v-t (f-exp (car ll)
        !           501:                               reg
        !           502:                               `((set ,(f-use reg) ,(g-specialchk (cadr ll)))
        !           503:                                 ,@v-t))))))
        !           504: 
        !           505: 
        !           506: (putprop 'rplaca 'f-rplaca 'x-spf)
        !           507: 
        !           508: 
        !           509: (def f-rplaca 
        !           510:   (lambda (v-l v-r v-t)
        !           511:          (cond ((f-one (cadr v-l))
        !           512:                 (f-exp (car v-l) 
        !           513:                        v-r
        !           514:                        (f-exp (cadr v-l) 
        !           515:                               (setq v-l (Gensym nil))
        !           516:                               (f-addi (list 'seta (f-use v-r) (f-use v-l))
        !           517:                                       v-t))))
        !           518:                (t (f-pusha v-l 
        !           519:                            (Gensym nil)
        !           520:                            (f-addi (list 'setas v-r) v-t))))))
        !           521: 
        !           522: (putprop 'rplacd 'f-rplacd 'x-spf)
        !           523: 
        !           524: 
        !           525: (def f-rplacd 
        !           526:   (lambda (v-l v-r v-t)
        !           527:          (cond ((f-one (cadr v-l))
        !           528:                 (f-exp (car v-l)
        !           529:                        v-r
        !           530:                        (f-exp (cadr v-l)
        !           531:                               (setq v-l (Gensym nil))
        !           532:                               (f-addi (list 'setd (f-use v-r) (f-use v-l)) v-t))))
        !           533:                (t (f-pusha v-l 
        !           534:                            (Gensym nil)
        !           535:                            (f-addi (list 'setds (f-use v-r)) v-t))))))
        !           536: 
        !           537: (putprop 'go 'f-go 'x-spf)
        !           538: 
        !           539: ;--- f-go - v-l : label to go to
        !           540: ;        - v-r : not used
        !           541: ;        - v-t : tail
        !           542: ; We allow non local go to's, however the goto must go no further than the
        !           543: ; first inclosing prog.
        !           544: ; f-go works by finding the w-labs associated with the first enclosing prog,
        !           545: ; and keeping track of the number of binding levels which must be traversed
        !           546: ; to get to that prog.o
        !           547: ; when it finds the correct w-labs, it checks if this label has been seen yet,
        !           548: ; if not iit assigns it a gensymed symbol.  
        !           549: ; if a binding level must be traversed, we eimit
        !           550: ;      (unbind n)      n is number of binding levels to traverse, 
        !           551: ;                      0 means current level only.
        !           552: ;      (go gensymedlabl)
        !           553: ;
        !           554: ; if this is a local goto only the (go gensymedlabl) will be emitted.
        !           555: ;
        !           556: (def f-go 
        !           557:   (lambda (v-l v-r v-t) 
        !           558:          (prog (use-labs levels)
        !           559:                (setq v-l (car v-l)) 
        !           560:                (setq use-labs
        !           561:                      (cond (w-ret w-labs)
        !           562:                            (t (do ((ll w-save (cdr ll))
        !           563:                                    (count 0 (add1 count)))
        !           564:                                   ((null ll)
        !           565:                                    (comp-err " go not within prog"))
        !           566:                                   (cond ((caar ll)
        !           567:                                          (setq levels count)
        !           568:                                          (comp-warn " non-local go used")
        !           569:                                          (return (cadar ll))))))))
        !           570:                
        !           571:                (cond ((not (setq v-r (get use-labs v-l))) 
        !           572:                       (put use-labs v-l (setq v-r (Gensym nil))))) 
        !           573:                (setq v-t (f-addi (list 'go v-r) v-t))
        !           574:                (cond (levels (setq v-t (f-addi `(unbind ,levels) v-t))))
        !           575:                (return v-t)))) 
        !           576: 
        !           577: (putprop 'lambda 'f-lambda 'x-spf)
        !           578: 
        !           579: ;--- f-lambda - ?? how is this routine called, certainly this isnt the
        !           580: ;              same as ((lambda (n) form)  arg)
        !           581: ;
        !           582: 
        !           583: (putprop 'and 'f-and 'x-spf)
        !           584: 
        !           585: (def f-and 
        !           586:   (lambda (v-l v-r v-t) 
        !           587:         (f-aor v-l 'and v-r v-t))) 
        !           588: 
        !           589: (putprop 'or 'f-or 'x-spf)
        !           590: 
        !           591: (def f-or 
        !           592:   (lambda (v-l v-r v-t) 
        !           593:         (f-aor v-l 'or v-r v-t))) 
        !           594: 
        !           595: 
        !           596: 
        !           597: (putprop 'prog2 'prog2toprog 'x-spfm)
        !           598: 
        !           599: 
        !           600: ;--- prog2toprog - v-e : prog2 expression
        !           601: ; we convert this (prog2 a b c d e f) to
        !           602: ;      (progn a ((lambda (newsim) c d e f newsim) b))
        !           603: ; simple enough.
        !           604: ;
        !           605: (def prog2toprog
        !           606:   (lambda (v-e)
        !           607:          ((lambda (newsim)
        !           608:                   `(progn ,(cadr v-e)
        !           609:                           ((lambda (,newsim)
        !           610:                                    ,@(cdddr v-e)
        !           611:                                    ,newsim)
        !           612:                            ,(caddr v-e))))
        !           613:           (Gensym nil))))
        !           614: 
        !           615: 
        !           616: (putprop 'progn 'f-seq 'x-spf)
        !           617: 
        !           618: (putprop 'return 'f-return 'x-spfn)
        !           619: 
        !           620: ;--- f-return - v-l : arg to return, may be nil meaning return nil
        !           621: ;            - v-r : psreg in which to store result
        !           622: ;            - v-t : tail
        !           623: ;      this handles the return statement.  While returns should
        !           624: ;      occur in progs, this allows for a return inside a context
        !           625: ;      which is inside a prog (or do).  If this is a simple return
        !           626: ;      from prog or do, we have:
        !           627: ;              ... code to place to be returned val in v-r
        !           628: ;            (go retlb)        jump to label at end of prog body
        !           629: ;                              but before special unbinding
        !           630: ;      for non local cases we have
        !           631: ;              ...   code to place value to be returned into v-r
        !           632: ;            (unwind levels)  where is levels is the number of enclosing
        !           633: ;                    contexts (which begin with a (begin xx)) to return
        !           634: ;                    from.
        !           635: ;            (go retlb)        then go to the return spot.
        !           636: ;
        !           637: (def f-return
        !           638:   (lambda (v-l v-r v-t) 
        !           639:          (prog (use-ret levels)
        !           640:                (setq use-ret 
        !           641:                      (cond (w-ret)
        !           642:                            (t (do ((ll w-save (cdr ll))
        !           643:                                    (count 0 (add1 count)))
        !           644:                                   ((null ll) 
        !           645:                                    (comp-err " return not within a prog"))
        !           646:                                   (cond ((caar ll)
        !           647:                                          (setq levels count)
        !           648:                                          (comp-warn " non local return used")
        !           649:                                          (return (caar ll))))))))
        !           650:                
        !           651:                (setq v-t (f-addi (cdr use-ret) v-t)) 
        !           652:                (cond (levels (setq v-t (f-addi `(unbind ,levels) v-t))))
        !           653:                (return (f-exp (and v-l (car v-l)) (f-use (car use-ret)) v-t))))) 
        !           654: 
        !           655: (putprop 'null 'f-null 'x-spfn)
        !           656: 
        !           657: (def f-null 
        !           658:   (lambda (v-l v-r v-t) 
        !           659:          (cond ((f-test v-t) 
        !           660:                 (rplaca (cdar (rplacd v-t (f-xval (f-swap (cdr v-t)) v-r)))
        !           661:                         (f-use (setq v-r (Gensym nil))))
        !           662:                 (f-exp (car v-l) v-r v-t)))))
        !           663: 
        !           664: (putprop 'not 'f-null 'x-spfn)
        !           665: 
        !           666: 
        !           667: (def f-type 
        !           668:   (lambda (v-l v-r v-t v-bits) 
        !           669:          (cond ((f-test v-t) 
        !           670:                 (setq v-t (f-xval (cdr v-t) v-r))
        !           671:                 (f-exp (car v-l) 
        !           672:                        (setq v-r (Gensym nil))
        !           673:                        (f-addi (list 'getype (f-use v-r) v-bits) v-t)))))) 
        !           674: 
        !           675: (putprop 'atom 'f-atom 'x-spfn)
        !           676: 
        !           677: (def f-atom 
        !           678:   (lambda (v-l v-r v-t)
        !           679:          (f-type v-l v-r v-t '(0 1 2 4 5 6 7 9 10))))
        !           680: 
        !           681: (putprop 'numberp 'f-numberp 'x-spfn)
        !           682: 
        !           683: (def f-numberp 
        !           684:   (lambda (v-l v-r v-t) 
        !           685:          (f-type v-l v-r v-t '(2 4 9))))
        !           686: 
        !           687: (putprop 'symbolp 'f-symbolp 'x-spfn)
        !           688: 
        !           689: (def f-symbolp 
        !           690:   (lambda (v-l v-r v-t)
        !           691:        (f-type v-l v-r v-t 1)))
        !           692: 
        !           693: (putprop 'dtpr 'f-dtpr 'x-spfn)
        !           694: 
        !           695: (def f-dtpr 
        !           696:   (lambda (v-l v-r v-t)
        !           697:          (f-type v-l v-r v-t 3)))
        !           698: 
        !           699: (putprop 'bcdp 'f-bcdp 'x-spfn)
        !           700: 
        !           701: (def f-bcdp 
        !           702:   (lambda (v-l v-r v-t)
        !           703:          (f-type v-l v-r v-t 5)))
        !           704: 
        !           705: (putprop 'stringp 'f-stringp 'x-spfn)
        !           706: 
        !           707: (def f-stringp 
        !           708:   (lambda (v-l v-r v-t)
        !           709:          (f-type v-l v-r v-t 0)))
        !           710: 
        !           711: (putprop 'type 'f-ty 'x-spfn)
        !           712: 
        !           713: (def f-ty 
        !           714:   (lambda (v-l v-r v-t)
        !           715:          (f-exp (car v-l) 
        !           716:                 (setq v-r (Gensym nil))
        !           717:                 (f-addi (list 'getype (f-use v-r) 'name) v-t))))
        !           718: 
        !           719: (putprop 'eq 'f-eq 'x-spfn)
        !           720: 
        !           721: (def f-eq 
        !           722:   (lambda (v-l v-r v-t)
        !           723:          (prog (v-r1)
        !           724:                (cond ((f-test v-t)
        !           725:                       (setq v-t (f-xval (cdr v-t) v-r))
        !           726:                       (cond ((and (f-one (car v-l)) (f-one (cadr v-l)))
        !           727:                              (return (f-addi (list 'eqv (car v-l) (cadr v-l))
        !           728:                                              v-t))))
        !           729:                       (return (f-pusha v-l 
        !           730:                                        (Gensym nil)
        !           731:                                        (f-addi '(eqs) v-t))))))))
        !           732: 
        !           733: (putprop 'cons 'f-repl 'x-spfh)
        !           734: 
        !           735: '(putprop 'map 'f-domap 'x-spfh)
        !           736: 
        !           737: '(putprop 'mapc 'f-domap 'x-spfh)
        !           738: 
        !           739: '(putprop 'mapcar 'f-domap 'x-spfh)
        !           740: 
        !           741: '(putprop 'maplist 'f-domap 'x-spfh)
        !           742: 
        !           743: (putprop 'zerop 'f-zerop 'x-spfm)
        !           744: 
        !           745: (def f-zerop 
        !           746:   (lambda (v-e)
        !           747:          (list 'equal 0 (cadr v-e))))
        !           748: 
        !           749: (putprop 'plist 'f-plist 'x-spfm)
        !           750: 
        !           751: (def f-plist 
        !           752:   (lambda (v-e)
        !           753:          (list 'car (cadr v-e))))
        !           754: 
        !           755: (putprop 'go 'f-xgo 'x-opt)
        !           756: 
        !           757: (def f-xgo 
        !           758:   (lambda (v-i v-t) 
        !           759:          (setq v-t (f-chop v-t)) 
        !           760:          (cond ((equal (cadr v-i) (cadar v-t)) v-t) 
        !           761:                (t (cons v-i v-t))))) 
        !           762: 
        !           763: (putprop 'return 'f-xreturn 'x-opt)
        !           764: 
        !           765: (def f-xreturn 
        !           766:   (lambda (v-i v-t) 
        !           767:          (cons v-i (f-chop v-t)))) 
        !           768: 
        !           769: (putprop 'repeat 'f-xreturn 'x-opt)
        !           770: 
        !           771: (putprop 'false 'f-tfo 'x-opt) 
        !           772: 
        !           773: (putprop 'true 'f-tfo 'x-opt) 
        !           774: 
        !           775: 
        !           776: (putprop '*catch 'f-*catch 'x-spf)
        !           777: 
        !           778: 
        !           779: ;--- f-*catch - v-l : list of (tag exp) , tag is evaled, exp is to be run
        !           780: ;           - v-r : result register
        !           781: ;           - v-t : tail
        !           782: ;      This compiles a catch by emiting these intermediate codes:
        !           783: ;      ..calculate tag..
        !           784: ;      (catchent <gensym> <tag> nil)
        !           785: ;       .. code to eval (car v-l) ..
        !           786: ;      (catchexit)
        !           787: ;      (label <gensym>)
        !           788: ;
        !           789: ;      The catchent sets up a catch frame on the c-runtime stack.
        !           790: ;      The (car v-l) is evaluated and the result placed in r0 (it must
        !           791: ;      be since that is where the value would be thrown). If no throw
        !           792: ;      is done, it enters the catchexit which pops our catchframe off
        !           793: ;      the stack. If a throw is done it ends up at the label <gensym>
        !           794: ;      with the catch frame already popped off.
        !           795: ;
        !           796: (def f-*catch
        !           797:   (lambda (v-l v-r v-t)
        !           798:          (prog (v-loop v-tag x y z v-nr)
        !           799:                (setq v-tag (car v-l))
        !           800:                ; we check to make sure we can force v-r to be r0, else
        !           801:                ; we must give up.
        !           802:                (cond ((and  (get v-r 'x-reg) 
        !           803:                             (not (equal (get v-r 'x-reg) 0)))
        !           804:                       (err '"Can't compile catch correctly"))
        !           805:                      (t (f-make v-r 0)))
        !           806: 
        !           807:                (return
        !           808:                 (f-exp v-tag
        !           809:                        (setq v-nr (Gensym nil))
        !           810:                        (f-addi `(catchent ,(setq v-loop (Gensym nil)) 
        !           811:                                           ,(f-use v-nr)
        !           812:                                           nil)
        !           813:                                (f-exp (cadr v-l) (f-use v-r)
        !           814:                                       (f-addi `(catchexit)
        !           815:                                               (f-addi `(label ,v-loop) v-t)))))))))
        !           816: 
        !           817: (putprop 'errset 'f-errset 'x-spf)
        !           818: ;--- f-errset - v-l : list of (errset form [flag])
        !           819: ;            - v-r : place to put result.
        !           820: ;            - v-t : tail
        !           821: ;
        !           822: ;      This sets up an errset frame.  It is different than a catch in
        !           823: ;      that the tag is always (ER%all) and the result returned upon
        !           824: ;      a regular exit is listified.
        !           825: ;      again, we must insure that v-r can be forced to be r0 since
        !           826: ;      an err or error will place the result there.
        !           827: ;
        !           828: (def f-errset
        !           829:   (lambda (v-l v-r v-t)
        !           830:          (prog (v-loop v-tag v-flag v-nr)
        !           831:                (cond ((and (get v-r 'x-reg) (not (equal (get v-r 'x-reg) 0)))
        !           832:                       (err '"Can't compile errset  correctly"))
        !           833:                      (t (f-make v-r 0)))
        !           834: 
        !           835:                ; flag tells if error message will be reported, t if so.
        !           836:                ; t is the default
        !           837:                (cond ((cdr v-l) (setq v-flag (cadr v-l)))
        !           838:                      (t (setq v-flag t)))
        !           839: 
        !           840:                (return
        !           841:                  (f-exp v-flag
        !           842:                         (setq v-nr (Gensym nil))
        !           843:                         (f-addi `(catchent ,(setq v-loop (Gensym nil)) 
        !           844:                                            '(ER%all)
        !           845:                                            ,(f-use v-nr))
        !           846:                                 (f-exp (car v-l)
        !           847:                                        v-r
        !           848:                                        `((catchexit)
        !           849:                                          (push ,v-r)
        !           850:                                          (call ,v-r _Lncons 1)
        !           851:                                          (label ,v-loop)
        !           852:                                          ,@v-t))))))))
        !           853: 
        !           854: 
        !           855: 
        !           856: 
        !           857: (putprop '*throw 'f-*throw 'x-spf)
        !           858: 
        !           859: ;--- f-*throw - v-l : list of (tag exp)
        !           860: ;           - v-r : loc to eval exp to
        !           861: ;           - v-t : tail
        !           862: ;
        !           863: (def f-*throw
        !           864:   (lambda (v-l v-r v-t)
        !           865:          (let ((v-nr (Gensym nil)))
        !           866:               (f-exp (car v-l) 
        !           867:                      v-nr
        !           868:                       (f-exp (cadr v-l) v-r
        !           869:                              (f-addi `(*throw ,(f-use v-r) ,(f-use v-nr)) v-t))))))
        !           870: 
        !           871: 
        !           872: (putprop 'arg 'f-arg 'x-spf)
        !           873: 
        !           874: ;--- f-arg - v-l : list of arg to evaluate
        !           875: ;         - v-r : place to store value
        !           876: ;         - v-t : tail
        !           877: (def f-arg
        !           878:   (lambda (v-l v-r v-t)
        !           879:          (f-exp (car v-l) v-r
        !           880:                 (f-addi `(arg ,(f-use v-r))
        !           881:                         v-t))))

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