Return to cadr.l CVS log

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

Annotation of 40BSD/cmd/liszt/cadr.l, revision 1.1

1.1     ! root        1: 
        !             2: 
        !             3: ;              l i s z t   v 4
        !             4: 
        !             5: 
        !             6: 
        !             7: 
        !             8: ; Copyright (c) 1980 ,  The Regents of the University of California.
        !             9: ; All rights reserved.  
        !            10: ; author: j. foderaro
        !            11: 
        !            12: ; Section EXPR  -- general expression compiler
        !            13: 
        !            14: (include "caspecs.l")
        !            15: 
        !            16: (eval-when (compile eval)
        !            17:   (cond ((not (getd 'If))
        !            18:         (fasl 'camacs))))
        !            19: 
        !            20: (setq sectioncadrid "@(#)cadr.l        5.4     10/22/80")  ; id for SCCS
        !            21: 
        !            22: ;--- d-exp :: compile a lisp expression                                = d-exp =
        !            23: ;      v-form : a lisp expression to compile
        !            24: ; returns an IADR which tells where the value was located.
        !            25: ;
        !            26: (defun d-exp (v-form)
        !            27:   (prog (first resloc tmp ftyp)
        !            28: 
        !            29:     begin
        !            30:        (If (atom v-form)
        !            31:            then (setq tmp (d-loc v-form))              ;locate vrble
        !            32:                 (If (null g-loc)
        !            33:                     then (If g-cc then (d-tst tmp))
        !            34:                     else (d-move tmp g-loc))
        !            35:                 (d-handlecc)
        !            36:                 (return tmp)
        !            37: 
        !            38:         elseif (atom (setq first (car v-form)))
        !            39:            then (If (and fl-xref (not (get first g-refseen)))
        !            40:                     then (Push g-reflst first)
        !            41:                          (putprop first t g-refseen))
        !            42:                 (setq ftyp (d-functyp first))
        !            43:                 (If (eq 'macro ftyp)
        !            44:                     then (setq v-form (apply first v-form))
        !            45:                          (go begin)
        !            46:                  elseif (setq tmp (get first 'fl-exprcc))
        !            47:                     then (return (funcall tmp))
        !            48:                  elseif (setq tmp (get first 'fl-exprm))
        !            49:                     then (setq v-form (funcall tmp))
        !            50:                          (go begin)
        !            51:                  elseif (setq tmp (get first 'fl-expr))
        !            52:                     then (funcall tmp)
        !            53:                  elseif (setq tmp (or (and (eq 'car first)
        !            54:                                            '( a ))
        !            55:                                       (and (eq 'cdr first)
        !            56:                                            '( d ))
        !            57:                                       (d-cxxr first)))
        !            58:                     then (return (cc-cxxr (cadr v-form) tmp))
        !            59:                   elseif (eq 'nlambda ftyp)
        !            60:                     then (d-callbig first `(',(cdr v-form)))
        !            61:                   elseif (or (eq 'lambda ftyp) (eq 'lexpr ftyp))
        !            62:                     then (setq tmp (length v-form))
        !            63:                     
        !            64:                          (d-callbig first (cdr v-form)))
        !            65:         elseif (eq 'lambda (car first))
        !            66:            then (c-lambexp)
        !            67: 
        !            68:         elseif (or (eq 'quote (car first)) (eq 'function (car first)))
        !            69:            then (comp-warn "bizzare function name " (or first))
        !            70:                 (setq v-form (cons (cadr first) (cdr v-form)))
        !            71:                 (go begin)
        !            72:                
        !            73:         else (comp-err "bad expression" (or v-form)))
        !            74: 
        !            75: (If (null g-loc)
        !            76:     then (If g-cc then (d-tst 'reg))
        !            77:  elseif (eq g-loc 'reg)
        !            78:     then (If g-cc then (d-tst 'reg))
        !            79:  else (d-move 'reg g-loc))
        !            80: (If g-cc then (d-handlecc))))
        !            81: 
        !            82: ;--- d-functyp :: return the type of function
        !            83: ;      - name : function name
        !            84: ;
        !            85: (defun d-functyp (name)
        !            86:   (let (ftyp )
        !            87:        (If (atom name) then 
        !            88:           (If (setq ftyp (getd name))
        !            89:               then (If (bcdp ftyp)
        !            90:                        then (getdisc ftyp)
        !            91:                     elseif (dtpr ftyp)
        !            92:                        then (car ftyp))
        !            93:             elseif (get name g-functype) thenret
        !            94:             else 'lambda))))           ; default is lambda
        !            95: 
        !            96: 
        !            97: ;--- d-exps :: compile a list of expressions
        !            98: ;      - exps : list of expressions
        !            99: ; the last expression is evaluated according to g-loc and g-cc, the others
        !           100: ; are evaluated with g-loc and g-cc nil.
        !           101: ;
        !           102: (defun d-exps (exps)
        !           103:   (d-exp (do ((ll exps (cdr ll))
        !           104:              (g-loc nil)
        !           105:              (g-cc  nil)
        !           106:              (g-ret nil))
        !           107:             ((null (cdr ll)) (car ll))
        !           108:             (d-exp (car ll)))))
        !           109: 
        !           110: 
        !           111: ;--- d-pushargs :: compile and push a list of expressions
        !           112: ;      - exps : list of expressions
        !           113: ; compiles and stacks a list of expressions
        !           114: ;
        !           115: (defun d-pushargs (args)
        !           116:   (If args then (do ((ll args (cdr ll))
        !           117:                     (g-loc 'stack)
        !           118:                     (g-cc nil)
        !           119:                     (g-ret nil))
        !           120:                    ((null ll))
        !           121:                    (d-exp (car ll))
        !           122:                    (Push g-locs nil)
        !           123:                    (incr g-loccnt))))
        !           124: 
        !           125: ;--- d-cxxr :: split apart a cxxr function name
        !           126: ;      - name : a possible cxxr function name
        !           127: ; returns the a's and d's between c and r in reverse order, or else
        !           128: ;  returns nil if this is not a cxxr name
        !           129: ;
        !           130: (defun d-cxxr (name)
        !           131:   (let ((expl (explodec name)))
        !           132:        (If (eq 'c (car expl))                  ; must begin with c
        !           133:           then (do ((ll (cdr expl) (cdr ll))
        !           134:                     (tmp)
        !           135:                     (res))
        !           136:                    (nil)
        !           137:                    (setq tmp (car ll))
        !           138:                    (If (null (cdr ll)) 
        !           139:                        then (If (eq 'r tmp)    ; must end in r
        !           140:                                 then (return res)
        !           141:                                 else (return nil))
        !           142:                     elseif (or (eq 'a tmp)     ; and contain only a's and d's
        !           143:                                (eq 'd tmp))
        !           144:                        then (setq res (cons tmp res))
        !           145:                     else (return nil))))))
        !           146: 
        !           147: ;--- d-call :: call another function
        !           148: ;      - name : name of funtion to call
        !           149: ;      - nargs : number of args stacked (including the function name)
        !           150: ;
        !           151: (defun d-call (name nargs)
        !           152:   (prog (tmp)
        !           153:        (forcecomment `(calling ,name))
        !           154:        (If (null (setq tmp (cdr (assoc nargs
        !           155:                                        '( (1 . (* -8 #.bind-reg))
        !           156:                                           (2 . (* -12 #.bind-reg))
        !           157:                                           (3 . (* -16 #.bind-reg))
        !           158:                                           (4 . (* -20 #.bind-reg))
        !           159:                                           (5 . (* -24 #.bind-reg)))))))
        !           160:            then   ; lbot will not be set up automatically
        !           161:                   (e-write3 'movab             ; must set up lbot
        !           162:                             `(,(* -4 nargs) #.Np-reg)
        !           163:                             '#.Lbot-reg)
        !           164:                   (setq tmp '(* -28 #.bind-reg)))
        !           165:        (e-write2 'jsb tmp)))
        !           166: 
        !           167: ;--- d-callbig :: call a local or global function      
        !           168: ;
        !           169: ;
        !           170: (defun d-callbig (name args)
        !           171:   (let ((tmp (get name g-localf))
        !           172:        c)
        !           173:        (forcecomment `(calling ,name))
        !           174:        (If (d-dotailrecursion name args) thenret
        !           175:         elseif tmp then ;-- local function call
        !           176:                    (d-pushargs args)
        !           177:                    (e-write2 'jsb (car tmp))
        !           178:                    (setq g-locs (nthcdr (setq c (length args)) g-locs))
        !           179:                    (setq g-loccnt (- g-loccnt c))
        !           180:        else (If fl-tran        ;-- transfer table linkage
        !           181:               then (d-pushargs args)
        !           182:                    (setq c (length args))
        !           183:                    (d-calltran name c)
        !           184:               else ;--- standard function call
        !           185:                    (d-pushargs `(',name ,@args))
        !           186:                    (d-call name (setq c (1+ (length args)))))
        !           187:             (setq g-locs (nthcdr c g-locs))
        !           188:             (setq g-loccnt (- g-loccnt c)))
        !           189:        (d-clearreg)))
        !           190:        
        !           191: 
        !           192: ;--- d-calltran :: call a function through the transfer table            = d-calltran =
        !           193: ;  name - name of function to call
        !           194: ;  c - number of arguments to the function
        !           195: ;
        !           196: (defun d-calltran (name c)
        !           197:   (e-write3 'movab `(,(* -4 c) #.Np-reg) '#.Lbot-reg)
        !           198:   (e-write3 'calls '$0 (concat "*trantb+" (d-tranloc name)))
        !           199:   (e-write3 'movl '#.Lbot-reg '#.Np-reg))
        !           200: 
        !           201: ;--- d-tranloc :: locate a function in the transfer table        = d-tranloc =
        !           202: ;
        !           203: ; return the offset we should use for this function call
        !           204: ;
        !           205: (defun d-tranloc (fname)
        !           206:   (cond ((get fname g-tranloc))
        !           207:        (t (Push g-tran fname)
        !           208:           (let ((newval (* 8 g-trancnt)))
        !           209:                (putprop fname newval g-tranloc)
        !           210:                (incr g-trancnt)
        !           211:                newval))))
        !           212: 
        !           213: ;--- d-dotailrecursion :: do tail recursion if possible
        !           214: ; name - function name we are to call
        !           215: ; args - arguments to give to function
        !           216: ;
        !           217: ; return t iff we were able to do tail recursion
        !           218: ; We can do tail recursion if:
        !           219: ;  g-ret is set indicating that the result of this call will be returned
        !           220: ;       as the value of the function we are compiling
        !           221: ;  the function we are calling, name, is the same as the function we are
        !           222: ;       compiling, g-fname
        !           223: ;  there are no variables shallow bound, since we would have to unbind
        !           224: ;       them, which may cause problems in the function.
        !           225: ;
        !           226: (defun d-dotailrecursion (name args)
        !           227:   (If (and g-ret 
        !           228:           (eq name g-fname)
        !           229:            (do ((loccnt 0)
        !           230:                (ll g-locs (cdr ll)))
        !           231:               ((null ll) (return t))
        !           232:               (If (dtpr (car ll))
        !           233:                   then (If (or (eq 'catcherrset (caar ll))
        !           234:                                (greaterp (cdar ll) 0))
        !           235:                            then (return nil))
        !           236:                   else (incr loccnt))))
        !           237:       then 
        !           238:            ; evalate the arguments and pop them back to the location of
        !           239:            ; the original args.
        !           240:            (makecomment '(tail merging))
        !           241:            (comp-note "Tail merging being done: " v-form)
        !           242:            (let ((g-locs g-locs)
        !           243:                  (g-loccnt g-loccnt))
        !           244:                 (d-pushargs args))     ; push then forget about
        !           245:            (let (base-reg nargs)
        !           246:                 (If (eq g-ftype 'lexpr)
        !           247:                     then ; the beginning of the local variables 
        !           248:                          ;has been stacked
        !           249:                          (e-write3 'addl2 '$4 'sp)     ; pop off arg count
        !           250:                          (e-write4 'addl3 '$4 "(sp)" Lbot-reg) 
        !           251:                          (setq base-reg Lbot-reg)      ; will push from   bot
        !           252:                     else (setq base-reg oLbot-reg)) ; will push from olbot
        !           253:                 (setq nargs (length args))
        !           254:                 (do ((i nargs (1- i))
        !           255:                      (top (* nargs -4) (+ top 4))
        !           256:                      (bot 0 (+ bot 4)))
        !           257:                     ((zerop i))
        !           258:                     (e-write3 'movl `(,top ,Np-reg) `(,bot ,base-reg)))
        !           259:                 (e-write3 'movab `(,(* 4 nargs) ,base-reg) Np-reg)
        !           260:                 (e-goto g-topsym))
        !           261:            t)) ; return t to indicate that tailrecursion was successful
        !           262: 
        !           263: 
        !           264: 
        !           265: 
        !           266: ; Section xxx -- specific function compilers
        !           267: ;
        !           268: 
        !           269: ;--- cc-and :: compile an and expression
        !           270: ; We evaluate forms from left to right as long as they evaluate to
        !           271: ; a non nil value.  We only have to worry about storing the value of
        !           272: ; the last expression in g-loc.
        !           273: ;
        !           274: (defun cc-and nil
        !           275:   (let ((finlab (d-genlab))
        !           276:        (finlab2)
        !           277:        (exps (If (cdr v-form) thenret else '(t))))     ; (and) ==> t
        !           278:        (If (null (cdr g-cc))
        !           279:           then (d-exp (do ((g-cc (cons nil finlab))
        !           280:                            (g-loc)
        !           281:                            (g-ret)
        !           282:                            (ll exps (cdr ll)))
        !           283:                           ((null (cdr ll)) (car ll))
        !           284:                           (d-exp (car ll))))
        !           285:                (If g-loc then (setq finlab2 (d-genlab))
        !           286:                               (e-goto finlab2)
        !           287:                               (e-label finlab)
        !           288:                               (d-move 'Nil g-loc)
        !           289:                               (e-label finlab2)
        !           290:                          else (e-label finlab))
        !           291:           else ;--- cdr g-cc is non nil, thus there is
        !           292:                ; a quick escape possible if one of the
        !           293:                ; expressions evals to nil
        !           294: 
        !           295:                (If (null g-loc) then (setq finlab (cdr g-cc)))
        !           296:                (d-exp (do ((g-cc (cons nil finlab))
        !           297:                            (g-loc)
        !           298:                            (g-ret)
        !           299:                            (ll exps (cdr ll)))
        !           300:                           ((null (cdr ll)) (car ll))
        !           301:                           (d-exp (car ll))))
        !           302:                ; if g-loc is non nil, then we have evaled the and
        !           303:                ; expression to yield nil, which we must store in
        !           304:                ; g-loc and then jump to where the cdr of g-cc takes us
        !           305:                (If g-loc then (setq finlab2 (d-genlab))
        !           306:                               (e-goto finlab2)
        !           307:                               (e-label finlab)
        !           308:                               (d-move 'Nil g-loc)
        !           309:                               (e-goto (cdr g-cc))
        !           310:                               (e-label finlab2))))
        !           311:   (d-clearreg))         ; we cannot predict the state of the registers
        !           312:            
        !           313:                          
        !           314: 
        !           315: 
        !           316: ;--- cc-arg  :: get the nth arg from the current lexpr         = cc-arg =
        !           317: ;
        !           318: ; the syntax for Franz lisp is (arg i)
        !           319: ; for interlisp the syntax is (arg x i) where x is not evaluated and is
        !           320: ; the name of the variable bound to the number of args.  We can only handle
        !           321: ; the case of x being the variable for the current lexpr we are compiling
        !           322: ;
        !           323: (defun cc-arg nil 
        !           324:   (let ((nillab (d-genlab)) (finlab (d-genlab)))
        !           325:        (If (not (eq 'lexpr g-ftype)) 
        !           326:           then (comp-err " arg only allowed in lexprs"))
        !           327:        (If (and (eq (length (cdr v-form)) 2)  fl-inter)
        !           328:           then (If (not (eq (car g-args) (cadr v-form)))
        !           329:                    then (comp-err " arg expression is for non local lexpr "
        !           330:                                   v-form)
        !           331:                    else (setq v-form (cdr v-form))))
        !           332:        (If (or g-loc g-cc)
        !           333:           then (let ((g-loc 'reg) 
        !           334:                      (g-cc (cons nil nillab))
        !           335:                      (g-ret))
        !           336:                     (d-exp `(cdr ,(cadr v-form))))     ; calc the numeric arg
        !           337:                (If g-loc then (d-move '"*-4(fp)[r0]" g-loc)
        !           338:                   else (e-tst '"*-4(fp)[r0]"))
        !           339:                (d-handlecc)
        !           340:                (e-goto finlab)
        !           341:                (e-label nillab)
        !           342:                ; here we are doing (arg nil) which returns the number of args
        !           343:                ; which is always true if anyone is testing 
        !           344:                (If g-loc then (d-move '"-8(fp)" g-loc)
        !           345:                               (d-handlecc)
        !           346:                   elseif (car g-cc) then (e-goto (car g-cc))) ;always true
        !           347:                (e-label finlab))))
        !           348: 
        !           349: 
        !           350: ;--- cc-atom :: test for atomness                              = cc-atom  =
        !           351: ;
        !           352: (defun cc-atom nil
        !           353:   (d-typecmplx (cadr v-form) 
        !           354:               '#.(concat '$ (plus 1_0 1_1 1_2 1_4 1_5 1_6 1_7 1_9 1_10))))
        !           355: 
        !           356: 
        !           357: ;--- cc-bcdp :: check for bcdpness                             = cc-bcdp  =
        !           358: ;
        !           359: (defun cc-bcdp nil
        !           360:   (d-typesimp (cadr v-form) '$5))
        !           361: 
        !           362: 
        !           363: ;--- cc-bigp :: check for bignumness                           = cc-bigp =
        !           364: ;
        !           365: (defun cc-bigp nil
        !           366:   (d-typesimp (cadr v-form) '$9))
        !           367: 
        !           368: ;--- c-*catch :: compile a *catch expression                   = c-*catch =
        !           369: ;
        !           370: ; the form of *catch is (*catch 'tag 'val)
        !           371: ; we evaluate 'tag and set up a catch frame, and then eval 'val
        !           372: ;
        !           373: (defun c-*catch nil
        !           374:   (let ((g-loc 'reg)
        !           375:        (g-cc nil)
        !           376:        (g-ret nil)
        !           377:        (finlab (d-genlab)))
        !           378:        (d-exp (cadr v-form))           ; calculate tag into r0
        !           379:        (d-catcherrset finlab 'reg 'T (caddr v-form))
        !           380:        (e-label finlab)))
        !           381: 
        !           382: 
        !           383: 
        !           384: ;--- d-catcherrset :: common code to catch and errset 
        !           385: ;
        !           386: (defun d-catcherrset (finlab tagloc  flagloc expr)
        !           387:        (e-write2 'pushab finlab)
        !           388:        (e-write2 'pushr '$0x2540)      ; save registers
        !           389:        (e-write2 'jsb '_svkludg)               ; save rest of state
        !           390:        (e-write2 'pushl Bnp-val)
        !           391:        (e-write2 'pushl (e-cvt tagloc))        ; push tag
        !           392:        (e-write2 'pushl (e-cvt flagloc))       ; non-nil flag
        !           393:        (e-write2 'pushl '_errp)                ; old error pointer
        !           394:        (e-write3 'movl 'sp '_errp)     ; set up new error pointer
        !           395:        (Push g-locs '(catcherrset . 0))
        !           396:        (d-exp expr)                    ; now do the expression
        !           397:        (unpush g-locs)
        !           398:        (e-write3 'movl '"(sp)" '_errp) ; unlink this error frame
        !           399:        (e-write3 'addl2 '$80 'sp)
        !           400:        (d-clearreg))                   ; cant predict contents after retune    
        !           401: 
        !           402: 
        !           403: ;--- c-cond :: compile a "cond" expression                     = c-cond =
        !           404: ;
        !           405: ; not that this version of cond is a 'c' rather than a 'cc' . 
        !           406: ; this was done to make coding this routine easier and because
        !           407: ; it is believed that it wont harm things much if at all
        !           408: ;
        !           409: (defun c-cond nil
        !           410:   (makecomment '(beginning cond))
        !           411:   (do ((clau (cdr v-form) (cdr clau))
        !           412:        (finlab (d-genlab))
        !           413:        (nxtlab)
        !           414:        (save-reguse)
        !           415:        (seent))
        !           416:       ((or (null clau) seent)
        !           417:        ; end of cond
        !           418:        ; if haven't seen a t must store a nil in r0
        !           419:        (If (null seent)  then (d-move 'Nil 'reg))
        !           420:        (e-label finlab))
        !           421: 
        !           422:       ; case 1 - expr
        !           423:       (If (atom (car clau))
        !           424:          then (comp-err "bad cond clause " (car clau))
        !           425:       ; case 2 - (expr)
        !           426:        elseif (null (cdar clau))
        !           427:          then (let ((g-loc (If (or g-cc g-loc) then 'reg))
        !           428:                     (g-cc (cons finlab nil))
        !           429:                     (g-ret))
        !           430:                    (d-exp (caar clau)))
        !           431:       ; case 3 - (t expr1 expr2 ...)
        !           432:        elseif (or (eq t (caar clau))
        !           433:                  (equal ''t (caar clau)))
        !           434:          then (let ((g-loc (If (or g-cc g-loc) then 'reg))
        !           435:                     g-cc)
        !           436:                    (d-exps (cdar clau)))
        !           437:               (setq seent t)
        !           438:       ; case 4 - (expr1 expr2 ...)
        !           439:        else (let ((g-loc nil)
        !           440:                  (g-cc (cons nil (setq nxtlab (d-genlab))))
        !           441:                  (g-ret nil))
        !           442:                 (d-exp (caar clau)))
        !           443:            (setq save-reguse (copy g-reguse))
        !           444:            (let ((g-loc (If (or g-cc g-loc) then 'reg))
        !           445:                  g-cc)
        !           446:                 (d-exps (cdar clau)))
        !           447:            (If (or (cdr clau) (null seent)) then (e-goto finlab))
        !           448:            (e-label nxtlab)
        !           449:            (setq g-reguse save-reguse)))
        !           450:   
        !           451:   (d-clearreg))
        !           452:              
        !           453: 
        !           454: 
        !           455: ;--- c-cons :: do a cons instruction quickly                   = c-cons =
        !           456: ;
        !           457: (defun c-cons nil
        !           458:   (d-pushargs (cdr v-form))            ; there better be 2 args
        !           459:   (e-write2 'jsb '_qcons)
        !           460:   (setq g-locs (cddr g-locs))
        !           461:   (setq g-loccnt (- g-loccnt 2))
        !           462:   (d-clearreg))
        !           463: 
        !           464: 
        !           465: ;--- c-cxr :: compile a cxr instruction                                = c-cxr =
        !           466: ; 
        !           467: ; this code would also be useful for accessing any vector of lispvals.
        !           468: ;
        !           469: (defun c-cxr nil
        !           470:   (prog (arg1 arg2 arg1loc arg2loc)
        !           471:        (setq arg1loc (d-simple (setq arg1 (list 'cdr (cadr v-form))))
        !           472:              arg2loc (d-simple (setq arg2 (caddr v-form))))
        !           473: 
        !           474:        (If (not (and (dtpr arg1loc) (eq 'immed (car arg1loc))))
        !           475:            then
        !           476:               (If arg2loc 
        !           477:                   then (If (null arg1loc) 
        !           478:                            then (let ((g-loc 'r1)
        !           479:                                       (g-cc))
        !           480:                                      (d-exp arg1))
        !           481:                            else (d-move arg1loc 'r1))
        !           482:                        (d-move arg2loc 'r0)
        !           483:                   else (d-pushargs (ncons arg1))
        !           484:                        (let ((g-loc 'r0)
        !           485:                              (g-cc))
        !           486:                             (d-exp arg2))
        !           487:                        (d-move 'unstack 'r1)
        !           488:                        (decr g-loccnt)
        !           489:                        (Pop g-locs))
        !           490:               (d-inreg 'r1 nil)                ; register clobbered
        !           491:               (If g-loc then (e-move `(0 r0 r1) (e-cvt g-loc))
        !           492:                              (d-handlecc)
        !           493:                elseif g-cc then (e-tst `(0 r0 r1))
        !           494:                                 (d-handlecc))
        !           495:            else (let ((g-loc 'r0)
        !           496:                       (g-cc))
        !           497:                      (d-exp arg2))
        !           498:                 (setq arg1loc (list (* 4 (cadr arg1loc)) 'r0))
        !           499:                 (If g-loc then (e-move arg1loc (e-cvt g-loc))
        !           500:                                (d-handlecc)
        !           501:                  elseif g-cc then (e-tst arg1loc)
        !           502:                                   (d-handlecc)))))
        !           503:                        
        !           504:                            
        !           505: ;--- cc-cxxr :: compile a "c*r" instr where *                  = c-cxxr =
        !           506: ;              is any sequence of a's and d's
        !           507: ;      - arg : argument of the cxxr function
        !           508: ;      - pat : a list of a's and d's in the reverse order of that
        !           509: ;                      which appeared between the c and r
        !           510: ;
        !           511: (defun cc-cxxr (arg pat)
        !           512:   (prog (resloc loc qloc sofar togo keeptrack)
        !           513:        ; check for the special case of nil, since car's and cdr's
        !           514:        ; are nil anyway
        !           515:        (If (null arg) then (If g-loc then (d-move 'Nil g-loc)
        !           516:                                           (d-handlecc)
        !           517:                             elseif (cdr g-cc) then (e-goto (cdr g-cc)))
        !           518:                            (return))
        !           519:                                      
        !           520:        (If (and (symbolp arg) (setq qloc (d-bestreg arg pat)))
        !           521:            then (setq resloc (car qloc)
        !           522:                       loc   resloc
        !           523:                       sofar  (cadr qloc)
        !           524:                       togo   (caddr qloc))
        !           525:         else (setq resloc (If (d-simple arg) thenret
        !           526:                                else (let ((g-loc 'reg)
        !           527:                                           (g-cc nil)
        !           528:                                           (g-ret nil))
        !           529:                                          (d-exp arg))
        !           530:                                'r0))
        !           531:               (setq sofar nil
        !           532:                     togo  pat))
        !           533: 
        !           534:        (If (and arg (symbolp arg)) then (setq keeptrack t))
        !           535: 
        !           536:        ; if resloc is a global variable, we must move it into a register
        !           537:        ; right away to be able to do car's and cdr's
        !           538:        (If (and (dtpr resloc) (or (eq (car resloc) 'bind)
        !           539:                                  (eq (car resloc) 'vstack)))
        !           540:           then (d-move resloc 'reg)
        !           541:                (setq resloc 'r0))
        !           542: 
        !           543:        ; now do car's and cdr's .  Values are placed in r0. We stop when
        !           544:        ; we can get the result in one machine instruction.  At that point
        !           545:        ; we see whether we want the value or just want to set the cc's.
        !           546:        ; If the intermediate value is in a register, 
        !           547:        ; we can do : car cdr cddr cdar
        !           548:        ; If the intermediate value is on the local vrbl stack or lbind
        !           549:        ; we can do : cdr
        !           550:        (do ((curp togo newp)
        !           551:            (newp))
        !           552:           ((null curp) (If g-loc then (d-movespec loc g-loc)
        !           553:                            elseif g-cc then (e-tst loc))
        !           554:                        (d-handlecc))
        !           555:           (If (symbolp resloc)
        !           556:               then (If (eq 'd (car curp))
        !           557:                        then (If (or (null (cdr curp))
        !           558:                                     (eq 'a (cadr curp)))
        !           559:                                 then (setq newp (cdr curp)   ; cdr
        !           560:                                            loc `(0 ,resloc)
        !           561:                                            sofar (append sofar (list 'd)))
        !           562:                                 else (setq newp (cddr curp)  ; cddr
        !           563:                                            loc `(* 0 ,resloc)
        !           564:                                            sofar (append sofar (list 'd 'd))))
        !           565:                        else (If (or (null (cdr curp))
        !           566:                                     (eq 'a (cadr curp)))
        !           567:                                 then (setq newp (cdr curp)   ; car
        !           568:                                            loc `(4 ,resloc)
        !           569:                                            sofar (append sofar (list 'a)))
        !           570:                                 else (setq newp (cddr curp)  ; cdar
        !           571:                                            loc `(* 4 ,resloc)
        !           572:                                            sofar (append sofar (list 'a 'd)))))
        !           573:               elseif (and (eq 'd (car curp))
        !           574:                           (not (eq '* (car (setq loc (e-cvt resloc))))))
        !           575:                 then (setq newp (cdr curp)     ; (cdr <local>)
        !           576:                            loc (cons '* loc)
        !           577:                            sofar (append sofar (list 'd)))
        !           578:               else  (setq loc (e-cvt resloc)
        !           579:                           newp curp))
        !           580:           (If newp                     ; if this is not the last move
        !           581:               then (setq resloc (d-allocreg (If keeptrack then nil else 'r0)))
        !           582:                    (d-movespec loc resloc)
        !           583:                    (If keeptrack then (d-inreg resloc (cons arg sofar)))))))
        !           584: 
        !           585: ;--- c-declare :: handle the "declare" form
        !           586: ; if a declare is seen inside a function definition, we just 
        !           587: ; ignore it.  We probably should see what it is declareing, as it
        !           588: ; might be declaring a special.
        !           589: ;
        !           590: (defun c-declare nil)
        !           591: 
        !           592: ;--- c-do :: compile a "do" expression                         = c-do =
        !           593: ;
        !           594: ; a do has this form:
        !           595: ;  (do vrbls tst . body)
        !           596: ; we note the special case of tst being nil, in which case the loop
        !           597: ; is evaluated only once, and thus acts like a let with labels allowed.
        !           598: ; The do statement is a cross between a prog and a lambda. It is like
        !           599: ; a prog in that labels are allowed. It is like a lambda in that
        !           600: ; we stack the values of all init forms then bind to the variables, just
        !           601: ; like a lambda expression (that is the initial values of even specials
        !           602: ; are stored on the stack, and then copied into the value cell of the
        !           603: ; atom during the binding phase. From then on the stack location is
        !           604: ; not used).
        !           605: ;
        !           606: (defun c-do nil
        !           607:   (prog (b-vrbls b-tst b-body chklab bodylab x-repeat x-vrbs x-fst
        !           608:        g-loc g-cc oldreguse)
        !           609:        (forcecomment '(beginning do))
        !           610:        (setq g-loc 'reg  chklab (d-genlab)   bodylab (d-genlab))
        !           611: 
        !           612:        (If (and (cadr v-form) (atom (cadr v-form)))
        !           613:            then (setq v-form (d-olddo-to-newdo (cdr v-form))))
        !           614: 
        !           615:        (Push g-locs (cons 'do 0 ))             ; begin our frame
        !           616: 
        !           617:        (setq b-vrbls (cadr v-form)
        !           618:              b-tst   (caddr v-form)
        !           619:              b-body  (cdddr v-form))
        !           620: 
        !           621:        ; push value of init forms on stack
        !           622:        (d-pushargs (mapcar '(lambda (x)
        !           623:                                     (If (atom x) then nil ; no init form => nil
        !           624:                                         else (cadr x)))
        !           625:                            b-vrbls))
        !           626: 
        !           627:        ; now bind to  the variables in the vrbls form
        !           628:        (d-bindlamb (mapcar '(lambda (x)
        !           629:                                     (If (atom x) then x
        !           630:                                         else (car x)))
        !           631:                            b-vrbls))
        !           632: 
        !           633:        ; search through body for all labels and assign them gensymed labels
        !           634:        (Push g-labs (cons (d-genlab)
        !           635:                           (do ((ll b-body (cdr ll))
        !           636:                                (res))
        !           637:                               ((null ll) res)
        !           638:                               (If (and (car ll) (symbolp (car ll)))
        !           639:                                   then (Push res  (cons (car ll) (d-genlab)))))))
        !           640: 
        !           641:        ; if the test is non nil, we do the test
        !           642:        ; another strange thing, a test form of (pred) will not return
        !           643:        ; the value of pred if it is not nil! it will return nil (in this
        !           644:        ; way, it is not like a cond clause)
        !           645:        (d-clearreg)
        !           646:        (If b-tst then (e-label chklab)
        !           647:                       (let ((g-cc (cons nil bodylab)) g-loc g-ret)
        !           648:                            (d-exp (car b-tst)))        ; eval test
        !           649:                                                        ; if false, do body
        !           650:                       (If (cdr b-tst) 
        !           651:                           then (setq oldreguse (copy g-reguse))
        !           652:                                (d-exps (cdr b-tst))
        !           653:                                (setq g-reguse oldreguse)
        !           654:                           else  (d-move 'Nil 'reg))
        !           655:                       (e-goto (caar g-labs))           ; leave do
        !           656:                       (e-label bodylab))               ; begin body
        !           657: 
        !           658:        ; process body
        !           659:        (do ((ll b-body (cdr ll))
        !           660:             (g-cc) (g-loc)(g-ret))
        !           661:            ((null ll))
        !           662:            (If (or (null (car ll)) (not (symbolp (car ll))))
        !           663:                then (d-exp (car ll))
        !           664:                else (e-label (cdr (assoc (car ll) (cdar g-labs))))
        !           665:                     (d-clearreg)))
        !           666: 
        !           667:        (If b-tst then ; determine all repeat forms which must be 
        !           668:                       ; evaluated, and all the variables affected.
        !           669:                       ; store the results in x-repeat and  x-vrbs
        !           670:                       ; if there is just one repeat form, we calculate
        !           671:                       ; its value directly into where it is stored,
        !           672:                       ; if there is more than one, we stack them
        !           673:                       ; and then store them back at once.
        !           674:                       (do ((ll b-vrbls (cdr ll)))
        !           675:                           ((null ll))
        !           676:                           (If (and (dtpr (car ll)) (cddar ll))
        !           677:                               then (Push x-repeat (caddar ll))
        !           678:                                    (Push x-vrbs   (caar ll))))
        !           679:                       (If x-vrbs 
        !           680:                            then (If (null (cdr x-vrbs))  ; if just one repeat..
        !           681:                                     then (let ((g-loc (d-locv (car x-vrbs)))
        !           682:                                                (g-cc nil))
        !           683:                                               (d-exp (car x-repeat)))
        !           684:                                     else (setq x-fst (car x-repeat))
        !           685:                                          (d-pushargs (nreverse (cdr x-repeat)))
        !           686:                                          (let ((g-loc (d-locv (car x-vrbs)))
        !           687:                                                (g-cc)
        !           688:                                                (g-ret))
        !           689:                                               (d-exp x-fst))
        !           690:                                          (do ((ll (cdr x-vrbs) (cdr ll)))
        !           691:                                              ((null ll))
        !           692:                                              (d-move 'unstack (d-locv (car ll)))
        !           693:                                              (setq g-locs (cdr g-locs))
        !           694:                                              (decr g-loccnt))))
        !           695:                      (e-goto chklab))
        !           696: 
        !           697:        (e-label (caar g-labs))                 ; end of do label
        !           698:        (d-clearreg)
        !           699:        (d-unbind)
        !           700:        (setq g-labs (cdr g-labs))))
        !           701: 
        !           702: 
        !           703: ;--- d-olddo-to-newdo  :: map old do to new do
        !           704: ;
        !           705: ; form of old do is  (do var tst . body)
        !           706: ; where var is a symbol, not nil
        !           707: ;
        !           708: (defun d-olddo-to-newdo (v-l)
        !           709:   `(do ((,(car v-l) ,(cadr v-l) ,(caddr v-l)))
        !           710:        (,(cadddr v-l))
        !           711:        ,@(cddddr v-l)))
        !           712: 
        !           713: 
        !           714: 
        !           715: ;--- cc-dtpr :: check for dtprness                             = cc-dtpr =
        !           716: ;
        !           717: (defun cc-dtpr nil
        !           718:   (d-typesimp (cadr v-form) '$3))
        !           719: 
        !           720: 
        !           721: ;--- cc-eq :: compile an "eq" expression                       = cc-eq =
        !           722: ;
        !           723: (defun cc-eq nil
        !           724:   (let ((arg1 (cadr v-form))
        !           725:        (arg2 (caddr v-form))
        !           726:        arg1loc
        !           727:        arg2loc)
        !           728:        (If (setq arg2loc (d-simple arg2))
        !           729:           then (If (setq arg1loc (d-simple arg1))
        !           730:                    then ; eq <simple> <simple>
        !           731:                         (d-cmp arg1loc arg2loc)
        !           732:                    else ; eq <nonsimple> <simple>
        !           733:                         (let ((g-loc 'reg)     ; put <nonsimple> in r0
        !           734:                               g-cc
        !           735:                               g-ret)
        !           736:                              (d-exp arg1))
        !           737:                         (d-cmp 'reg arg2loc))
        !           738:           else ; since second is nonsimple, must stack first
        !           739:                ; arg out of harms way
        !           740:                (let ((g-loc 'stack)
        !           741:                      g-cc
        !           742:                      g-ret)
        !           743:                     (d-exp arg1)
        !           744:                     (Push g-locs nil)
        !           745:                     (incr g-loccnt)
        !           746:                     (setq g-loc 'reg)          ; second arg to r0
        !           747:                     (d-exp arg2))
        !           748:                (d-cmp 'unstack 'reg)
        !           749:                (setq g-locs (cdr g-locs))
        !           750:                (decr g-loccnt)))
        !           751: 
        !           752:   (d-invert))
        !           753: 
        !           754: (defun cc-equal nil
        !           755:   (let ((lab1 (d-genlab))
        !           756:        (lab11 (d-genlab))
        !           757:        lab2)
        !           758:        (d-pushargs (cdr v-form))
        !           759:        (e-write3 'cmpl "-8(r6)" "-4(r6)")
        !           760:        (e-gotonil lab1)
        !           761:        (d-calltran 'equal '2)           ; not eq, try equal.
        !           762:        (d-clearreg)
        !           763:        (e-write2 'tstl 'r0)
        !           764:        (e-gotot lab11)         
        !           765:        (If g-loc then (d-move 'Nil g-loc))
        !           766:        (If (cdr g-cc) then (e-goto (cdr g-cc))
        !           767:           else (e-goto (setq lab2 (d-genlab))))
        !           768:        (e-writel lab1)
        !           769:        (e-dropnp 2)
        !           770:        (e-writel lab11)
        !           771:        (If g-loc then (d-move 'T g-loc))
        !           772:        (If (car g-cc) then (e-goto (car g-cc)))
        !           773:        (If lab2 then (e-writel lab2))
        !           774:        (setq g-locs (cddr g-locs))
        !           775:        (setq g-loccnt (- g-loccnt 2))))
        !           776: 
        !           777: 
        !           778: 
        !           779: 
        !           780: ;--- c-errset :: compile an errset expression                  = c-errset =
        !           781: ;
        !           782: ; the errset has this form: (errset 'value ['tag])
        !           783: ; where tag defaults to t.
        !           784: ;
        !           785: (defun c-errset nil
        !           786:   (let ((g-loc 'reg)
        !           787:        (g-cc nil)
        !           788:        (g-ret nil)
        !           789:        (finlab (d-genlab)))
        !           790:        (d-exp (If (cddr v-form) then (caddr v-form) else t))
        !           791:        (d-catcherrset finlab (d-loclit '(ER%all) nil) 'reg (cadr v-form))
        !           792:        (d-move 'reg 'stack)
        !           793:        (d-calltran 'ncons 1)
        !           794:        (e-label finlab)
        !           795:        (d-clearreg)))
        !           796: 
        !           797: 
        !           798: ;--- cc-fixp :: check for a fixnum or bignum                   = cc-fixp =
        !           799: ;
        !           800: (defun cc-fixp nil
        !           801:   (d-typecmplx (cadr v-form) 
        !           802:               '#.(concat '$ (plus 1_2 1_9))))
        !           803: 
        !           804: 
        !           805: ;--- cc-floatp :: check for a flonum                           = cc-floatp =
        !           806: ;
        !           807: (defun cc-floatp nil
        !           808:   (d-typesimp (cadr v-form) '$4))
        !           809: 
        !           810: 
        !           811: ;--- c-get :: do a get from the prop list
        !           812: ;
        !           813: (defun c-get nil
        !           814:   (If (not (eq 2 (length (cdr v-form))))
        !           815:       then (comp-err "Wrong number of args to get " v-form))
        !           816:   (d-pushargs (cdr v-form))            ; there better be 2 args
        !           817:   (e-write2 'jsb '_qget)
        !           818:   (d-clearreg)
        !           819:   (setq g-locs (cddr g-locs))
        !           820:   (setq g-loccnt (- g-loccnt 2)))
        !           821: 
        !           822: ;--- c-go :: compile a "go" expression                         = c-go =
        !           823: ;
        !           824: ; we only compile the (go symbol)type expression, we do not
        !           825: ; allow symbol to be anything by a non null symbol.
        !           826: ;
        !           827: (defun c-go nil
        !           828:   ; find number of frames we have to go down to get to the label
        !           829:   (do ((labs g-labs (cdr labs))
        !           830:        (locs g-locs)
        !           831:        (locals 0)
        !           832:        (specials 0)
        !           833:        (catcherrset 0)
        !           834:        (label))
        !           835:       ((null labs) (comp-err "go label not found for expression: " (or v-form)))
        !           836:       ; if there are any enclosing *catches or errsets, they will be
        !           837:       ; first in g-locs
        !           838:       (do nil 
        !           839:          ((not (and (dtpr (car locs)) (eq (caar locs) 'catcherrset))))
        !           840:          (incr catcherrset)
        !           841:          (unpush locs))
        !           842: 
        !           843:       (If (car labs) 
        !           844:          then (If (setq label (do ((lbs (cdar labs) (cdr lbs)))
        !           845:                                   ((null lbs))
        !           846:                                   (If (eq (caar lbs) (cadr v-form))
        !           847:                                       then (return (cdar lbs)))))
        !           848:                   then (If (not (eq labs g-labs))
        !           849:                            then (comp-warn "non local go used : " (or v-form)))
        !           850:                        (If (greaterp catcherrset 0)
        !           851:                            then (comp-warn "Go through a catch or errset " v-form)
        !           852:                                 (do ((i 0 (1+ i)))
        !           853:                                     ((equal catcherrset i))
        !           854:                                     (e-write3 'movl "(sp)" '_errp)
        !           855:                                     (e-write3 'addl2 '$80 'sp)))
        !           856:                        (e-pop locals)
        !           857:                        (If (greaterp specials 0)
        !           858:                            then (e-unshallowbind specials))
        !           859:                        (e-goto label)
        !           860:                        (return)))
        !           861:       ; tally all locals and specials used in this frame
        !           862:       (do ()
        !           863:          ((dtpr (car locs)) (setq specials (+ specials (cdar locs))
        !           864:                                   locs (cdr locs)))
        !           865:          (setq locs (cdr locs))
        !           866:          (incr locals))))
        !           867:                        
        !           868: 
        !           869: ;--- cc-ingnore :: just ignore this code
        !           870: ;
        !           871: (defun cc-ignore nil
        !           872:   nil)
        !           873: 
        !           874: ;--- c-lambexp :: compile a lambda expression                  = c-lambexp =
        !           875: ;
        !           876: (defun c-lambexp nil
        !           877:   (let ((g-loc (If (or g-loc g-cc) then 'reg))
        !           878:        (g-cc nil))
        !           879:        (Push g-locs (cons 'lambda  0)) ; add null lambda header
        !           880:        (d-pushargs (cdr v-form))               ; then push vals
        !           881:        (d-lambbody (car v-form))
        !           882:        (d-clearreg)))
        !           883: 
        !           884: ;--- d-lambbody :: do a lambda body
        !           885: ;      - body : body of lambda expression, eg (lambda () dld)
        !           886: ;
        !           887: (defun d-lambbody (body)
        !           888:   (d-bindlamb (cadr body))             ; bind locals
        !           889:   (setq g-labs (cons nil g-labs))      ; no labels allowed
        !           890:   (d-clearreg)
        !           891:   (d-exp (do ((ll (cddr body) (cdr ll))
        !           892:              (g-loc)
        !           893:              (g-cc)
        !           894:              (g-ret))
        !           895:             ((null (cdr ll)) (car ll))
        !           896:             (d-exp (car ll))))
        !           897: 
        !           898:   (setq g-labs (cdr g-labs))
        !           899:   (d-unbind))                          ; unbind this frame
        !           900: 
        !           901: 
        !           902: ;--- d-bindlamb :: bind  variables in lambda list
        !           903: ;      - vrbs : list of lambda variables, may include nil meaning ignore
        !           904: ;
        !           905: (defun d-bindlamb (vrbs)
        !           906:   (let ((res (d-bindlrec (reverse vrbs) g-locs 0 g-loccnt)))
        !           907:        (If res then (e-setupbind)
        !           908:                    (mapc '(lambda (vrb) (e-shallowbind (car vrb) (cdr vrb)))
        !           909:                          res)
        !           910:                    (e-unsetupbind))))
        !           911:   
        !           912: ;--- d-bindlrec :: recusive routine to bind lambda variables
        !           913: ;      - vrb : list of variables yet to bind
        !           914: ;      - locs : current location in g-loc
        !           915: ;      - specs : number of specials seen so far
        !           916: ;      - lev  : how far up from the bottom of stack we are.
        !           917: ; returns: list of elements, one for each special, of this form:
        !           918: ;              (<specialvrbname> stack <n>)
        !           919: ;      where specialvrbname is the name of the special variable, and n is
        !           920: ;      the distance from the top of the stack where its initial value is 
        !           921: ;      located
        !           922: ; also: puts the names of the local variables in the g-locs list, as well
        !           923: ;      as placing the number of special variables in the lambda header.
        !           924: ;
        !           925: (defun d-bindlrec (vrb locs specs lev)
        !           926:   (If vrb 
        !           927:       then (let ((spcflg (d-specialp (car vrb)))
        !           928:                 retv)
        !           929:                (If spcflg then (setq specs (1+ specs)))
        !           930:                
        !           931:                (If (cdr vrb)           ; if more vrbls to go ...
        !           932:                    then (setq retv (d-bindlrec (cdr vrb) 
        !           933:                                                (cdr locs)
        !           934:                                                specs
        !           935:                                                (1- lev)))
        !           936:                    else (rplacd (cadr locs) specs))    ; else fix up lambda hdr
        !           937:                
        !           938:                (If (not spcflg) then (rplaca locs (car vrb))
        !           939:                    else (Push retv `(,(car vrb) stack ,lev)))
        !           940:                
        !           941:                retv)))
        !           942: ;--- c-list :: compile a list expression                       = c-list =
        !           943: ;
        !           944: ; this is compiled as a bunch of conses with a nil pushed on the
        !           945: ; top for good measure
        !           946: ;
        !           947: (defun c-list nil
        !           948:   (prog (nargs)
        !           949:        (setq nargs (length (cdr v-form)))
        !           950:        (makecomment '(list expression))
        !           951:        (If (zerop nargs) then (d-move 'Nil 'reg)       ; (list) ==> nil
        !           952:                               (return))
        !           953:        (d-pushargs (cdr v-form))
        !           954:        (e-write2 'clrl '(+ #.Np-reg))  ; stack one nil
        !           955: 
        !           956:        ; now do the consing
        !           957:        (do ((i (max 1 nargs) (1- i)))
        !           958:           ((zerop i))
        !           959:           (e-write2 'jsb '_qcons)
        !           960:           (d-clearreg)
        !           961:           (If (> i 1) then (d-move 'reg 'stack)))
        !           962: 
        !           963:        (setq g-locs (nthcdr nargs g-locs)
        !           964:             g-loccnt (- g-loccnt nargs))))
        !           965: 
        !           966: 
        !           967: 
        !           968: ;--- d-mapconvert - access : function to access parts of lists
        !           969: ;                - join         : function to join results
        !           970: ;                - resu         : function to apply to result
        !           971: ;              - form   : mapping form
        !           972: ;      This function converts maps to an equivalent do form.
        !           973: ;
        !           974: (defun d-mapconvert (access join resu form )
        !           975:          (prog (vrbls finvar acc accform compform tmp)
        !           976: 
        !           977:                (setq finvar (gensym 'X)   ; holds result
        !           978: 
        !           979:                      vrbls (reverse
        !           980:                             (maplist '(lambda (arg)
        !           981:                                        ((lambda (temp)
        !           982:                                            (cond ((or resu (cdr arg))
        !           983:                                                   `(,temp ,(car arg)
        !           984:                                                           (cdr ,temp)))
        !           985:                                                  (t `(,temp 
        !           986:                                                       (setq ,finvar ,(car arg))
        !           987:                                                       (cdr ,temp)))))
        !           988:                                         (gensym 'X)))
        !           989:                                    (reverse (cdr form))))
        !           990: 
        !           991:                      acc (mapcar '(lambda (tem)
        !           992:                                           (cond (access `(,access ,(car tem)))
        !           993:                                                 (t (car tem))))
        !           994:                                  vrbls)
        !           995: 
        !           996:                      accform (cond ((or (atom (setq tmp (car form)))
        !           997:                                         (null (setq tmp (d-macroexpand tmp)))
        !           998:                                         (not (member (car tmp) '(quote function))))
        !           999:                                     `(funcall ,tmp ,@acc))
        !          1000:                                    (t `(,(cadr tmp) ,@acc))))
        !          1001:                (return
        !          1002:                 `((lambda (,finvar)
        !          1003:                    (do ( ,@vrbls)
        !          1004:                        ((null ,(caar vrbls)))
        !          1005:                        ,(cond ((eq join 'nconc)
        !          1006:                                `(setq ,finvar (nconc ,finvar ,accform)))
        !          1007:                               (join `(setq ,finvar (,join ,accform ,finvar)))
        !          1008:                               (t accform)))
        !          1009:                    ,(cond ((eq resu 'identity) finvar)
        !          1010:                           (resu `(,resu ,finvar))
        !          1011:                           (t finvar)))
        !          1012:                   nil ))))
        !          1013: ; apply to successive elements, return second arg
        !          1014: (defun cm-mapc nil
        !          1015:          (d-mapconvert 'car nil nil (cdr v-form)))
        !          1016: 
        !          1017: ; apply to successive elements, return list of results
        !          1018: (defun cm-mapcar nil
        !          1019:          (d-mapconvert 'car 'cons 'nreverse (cdr v-form)))
        !          1020: 
        !          1021: ; apply to successive elements, returned nconc of results
        !          1022: (defun cm-mapcan nil
        !          1023:          (d-mapconvert 'car 'nconc 'identity (cdr v-form)))
        !          1024: 
        !          1025: 
        !          1026: ; apply to successive sublists, return second arg
        !          1027: (defun cm-map nil
        !          1028:          (d-mapconvert nil nil nil (cdr v-form)))
        !          1029: 
        !          1030: 
        !          1031: ; apply to successive sublists, return list of results
        !          1032: (defun cm-maplist nil
        !          1033:          (d-mapconvert nil 'cons 'reverse (cdr v-form)))
        !          1034: 
        !          1035: ; apply to successive sublists, return nconc of results
        !          1036: (defun cm-mapcon nil
        !          1037:          (d-mapconvert nil 'nconc 'identity (cdr v-form)))
        !          1038: 
        !          1039: 
        !          1040: ;--- cc-memq :: compile a memq expression                      = cc-memq =
        !          1041: ;
        !          1042: (defun cc-memq nil
        !          1043:   (let ((loc1 (d-simple (cadr v-form)))
        !          1044:        (loc2 (d-simple (caddr v-form)))
        !          1045:        looploc finlab)
        !          1046:        (If loc2 then (d-clearreg 'r1)
        !          1047:                     (If loc1 then (d-move loc1 'r1)
        !          1048:                              else (let ((g-loc 'r1)
        !          1049:                                         g-cc
        !          1050:                                         g-ret)
        !          1051:                                        (d-exp (cadr v-form))))
        !          1052:                     (d-move loc2 'reg)
        !          1053:                else (let ((g-loc 'stack)
        !          1054:                           g-cc
        !          1055:                           g-ret)
        !          1056:                          (d-exp (cadr v-form)))
        !          1057:                     (Push g-locs nil)
        !          1058:                     (incr g-loccnt)
        !          1059:                     (let ((g-loc 'reg)
        !          1060:                           g-cc
        !          1061:                           g-ret)
        !          1062:                          (d-exp (caddr v-form)))
        !          1063:                     (d-move 'unstack 'r1)
        !          1064:                     (d-clearreg 'r1)
        !          1065:                     (unpush g-locs)
        !          1066:                     (decr g-loccnt))
        !          1067:        ; now set up the jump addresses
        !          1068:        (If (null g-loc)
        !          1069:           then (setq loc1 (If (car g-cc) thenret
        !          1070:                               else (d-genlab))
        !          1071:                      loc2 (If (cdr g-cc) thenret
        !          1072:                               else (d-genlab)))
        !          1073:           else (setq loc1 (d-genlab)
        !          1074:                      loc2 (d-genlab)))
        !          1075: 
        !          1076:        (setq looploc (d-genlab))
        !          1077: 
        !          1078:        (e-write2 'tstl 'r0)
        !          1079:        (e-write2 'jeql loc2)
        !          1080:        (e-label looploc)
        !          1081:        (e-write3 'cmpl 'r1 "4(r0)")
        !          1082:        (e-write2 'jeql loc1)
        !          1083:        (e-write3 'movl "(r0)" 'r0)
        !          1084:        (e-write2 'jneq looploc)
        !          1085:        (If g-loc then (e-label loc2)           ; nil result
        !          1086:                      (d-move 'reg g-loc)
        !          1087:                      (If (cdr g-cc) then (e-goto (cdr g-cc))
        !          1088:                                     else (e-goto (setq finlab (d-genlab))))
        !          1089:                 else (If (cdr g-cc) then (e-goto (cdr g-cc))
        !          1090:                                     else (e-label loc2)))
        !          1091:        (If g-loc then (e-label loc1)           ; non nil result
        !          1092:                      (d-move 'reg g-loc)
        !          1093:                      (If (car g-cc) then (e-goto (car g-cc)))
        !          1094:                 else (If (null (car g-cc)) then (e-label loc1)))
        !          1095:        (If finlab then (e-label finlab))))
        !          1096: 

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