Return to funb.l CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt

Annotation of 43BSDTahoe/ucb/lisp/liszt/funb.l, revision 1.1

1.1     ! root        1: (include-if (null (get 'chead 'version)) "../chead.l")
        !             2: (Liszt-file funb
        !             3:    "$Header: funb.l,v 1.13 87/12/15 17:02:17 sklower Exp $")
        !             4: 
        !             5: ;;; ----       f u n b                         function compilation
        !             6: ;;;
        !             7: ;;;                            -[Wed Aug 24 17:14:56 1983 by layer]-
        !             8: 
        !             9: ;--- c-declare :: handle the "declare" form
        !            10: ; if a declare is seen inside a function definition, we just 
        !            11: ; ignore it.  We probably should see what it is declareing, as it
        !            12: ; might be declaring a special.
        !            13: ;
        !            14: (defun c-declare nil nil)
        !            15: 
        !            16: ;--- c-do :: compile a "do" expression
        !            17: ;
        !            18: ; a do has this form:
        !            19: ;  (do vrbls tst . body)
        !            20: ; we note the special case of tst being nil, in which case the loop
        !            21: ; is evaluated only once, and thus acts like a let with labels allowed.
        !            22: ; The do statement is a cross between a prog and a lambda. It is like
        !            23: ; a prog in that labels are allowed. It is like a lambda in that
        !            24: ; we stack the values of all init forms then bind to the variables, just
        !            25: ; like a lambda expression (that is the initial values of even specials
        !            26: ; are stored on the stack, and then copied into the value cell of the
        !            27: ; atom during the binding phase. From then on the stack location is
        !            28: ; not used).
        !            29: ;
        !            30: (defun c-do nil
        !            31:    (let (b-vrbls b-tst b-body chklab bodylab x-repeat x-vrbs x-fst
        !            32:                 g-loc g-cc oldreguse (g-decls g-decls))
        !            33:        (forcecomment '(beginning do))
        !            34:        (setq g-loc 'reg  chklab (d-genlab)   bodylab (d-genlab))
        !            35: 
        !            36:        (if (and (cadr v-form) (atom (cadr v-form)))
        !            37:           then (setq v-form (d-olddo-to-newdo (cdr v-form))))
        !            38: 
        !            39:        (push (cons 'do 0) g-locs)              ; begin our frame
        !            40: 
        !            41:        (setq b-vrbls (cadr v-form)
        !            42:             b-tst   (caddr v-form)
        !            43:             b-body  (cdddr v-form))
        !            44: 
        !            45:        (d-scanfordecls b-body)
        !            46: 
        !            47:        ; push value of init forms on stack
        !            48:        (d-pushargs (mapcar '(lambda (x)
        !            49:                                (if (atom x)
        !            50:                                    then nil ; no init form => nil
        !            51:                                    else (cadr x)))
        !            52:                           b-vrbls))
        !            53: 
        !            54:        ; now bind to  the variables in the vrbls form
        !            55:        (d-bindlamb (mapcar '(lambda (x)
        !            56:                                (if (atom x) then x
        !            57:                                    else (car x)))
        !            58:                           b-vrbls))
        !            59: 
        !            60:        ; search through body for all labels and assign them gensymed labels
        !            61:        (push (cons (d-genlab)
        !            62:                   (do ((ll b-body (cdr ll))
        !            63:                        (res))
        !            64:                       ((null ll) res)
        !            65:                       (if (and (car ll) (symbolp (car ll)))
        !            66:                           then (Push res
        !            67:                                      (cons (car ll) (d-genlab))))))
        !            68:             g-labs)
        !            69: 
        !            70:        ; if the test is non nil, we do the test
        !            71:        ; another strange thing, a test form of (pred) will not return
        !            72:        ; the value of pred if it is not nil! it will return nil -- in this
        !            73:        ; way, it is not like a cond clause
        !            74:        (d-clearreg)
        !            75:        (if b-tst then (e-label chklab)
        !            76:           (let ((g-cc (cons nil bodylab)) g-loc g-ret)
        !            77:               (d-exp (car b-tst)))     ; eval test
        !            78:           ; if false, do body
        !            79:           (if (cdr b-tst) 
        !            80:               then (setq oldreguse (copy g-reguse))
        !            81:                    (d-exps (cdr b-tst))
        !            82:                    (setq g-reguse oldreguse)
        !            83:               else  (d-move 'Nil 'reg))
        !            84:           (e-goto (caar g-labs))               ; leave do
        !            85:           (e-label bodylab))           ; begin body
        !            86: 
        !            87:        ; process body
        !            88:        (do ((ll b-body (cdr ll))
        !            89:            (g-cc) (g-loc)(g-ret))
        !            90:           ((null ll))
        !            91:           (if (or (null (car ll)) (not (symbolp (car ll))))
        !            92:               then (d-exp (car ll))
        !            93:               else (e-label (cdr (assoc (car ll) (cdar g-labs))))
        !            94:                    (d-clearreg)))
        !            95: 
        !            96:        (if b-tst
        !            97:           then ; determine all repeat forms which must be
        !            98:                ; evaluated, and all the variables affected.
        !            99:                ; store the results in x-repeat and  x-vrbs
        !           100:                ; if there is just one repeat form, we calculate
        !           101:                ; its value directly into where it is stored,
        !           102:                ; if there is more than one, we stack them
        !           103:                ; and then store them back at once.
        !           104:                (do ((ll b-vrbls (cdr ll)))
        !           105:                    ((null ll))
        !           106:                    (if (and (dtpr (car ll)) (cddar ll))
        !           107:                        then (Push x-repeat (caddar ll))
        !           108:                             (Push x-vrbs   (caar ll))))
        !           109:                (if x-vrbs 
        !           110:                    then (if (null (cdr x-vrbs))  ; if just one repeat
        !           111:                             then (let ((g-loc (d-locv (car x-vrbs)))
        !           112:                                        (g-cc nil))
        !           113:                                      (d-exp (car x-repeat)))
        !           114:                             else (setq x-fst (car x-repeat))
        !           115:                                  (d-pushargs (nreverse
        !           116:                                                  (cdr x-repeat)))
        !           117:                                  (let ((g-loc (d-locv (car x-vrbs)))
        !           118:                                        (g-cc)
        !           119:                                        (g-ret))
        !           120:                                      (d-exp x-fst))
        !           121:                                  (do ((ll (cdr x-vrbs) (cdr ll)))
        !           122:                                      ((null ll))
        !           123:                                      (d-move 'unstack
        !           124:                                              (d-locv (car ll)))
        !           125:                                      (setq g-locs (cdr g-locs))
        !           126:                                      (decr g-loccnt))))
        !           127:                (e-goto chklab))
        !           128: 
        !           129:        (e-label (caar g-labs))                 ; end of do label
        !           130:        (d-clearreg)
        !           131:        (d-unbind)
        !           132:        (setq g-labs (cdr g-labs))))
        !           133: 
        !           134: ;--- d-olddo-to-newdo  :: map old do to new do
        !           135: ;
        !           136: ; form of old do is  (do var tst . body)
        !           137: ; where var is a symbol, not nil
        !           138: ;
        !           139: (defun d-olddo-to-newdo (v-l)
        !           140:   `(do ((,(car v-l) ,(cadr v-l) ,(caddr v-l)))
        !           141:        (,(cadddr v-l))
        !           142:        ,@(cddddr v-l)))
        !           143: 
        !           144: ;--- cc-dtpr :: check for dtprness
        !           145: ;
        !           146: (defun cc-dtpr nil
        !           147:   (d-typesimp (cadr v-form) #.(immed-const 3)))
        !           148: 
        !           149: ;--- cc-eq :: compile an "eq" expression
        !           150: ;
        !           151: (defun cc-eq nil
        !           152:    (let ((arg1 (cadr v-form))
        !           153:         (arg2 (caddr v-form))
        !           154:         arg1loc
        !           155:         arg2loc)
        !           156:        (if (setq arg2loc (d-simple arg2))
        !           157:           then (if (setq arg1loc (d-simple arg1))
        !           158:                    then ; eq <simple> <simple>
        !           159:                         (d-cmp arg1loc arg2loc)
        !           160:                    else ; eq <nonsimple> <simple>
        !           161:                         (let ((g-loc 'reg)     ; put <nonsimple> in reg
        !           162:                               ; must rebind because
        !           163:                               ; cc->& may have modified
        !           164:                               (g-trueop #+(or for-vax for-tahoe) 'jneq
        !           165:                                         #+for-68k 'jne)
        !           166:                               (g-falseop #+(or for-vax for-tahoe) 'jeql
        !           167:                                          #+for-68k 'jeq)
        !           168:                               g-cc
        !           169:                               g-ret)
        !           170:                             (d-exp arg1))
        !           171:                         (d-cmp 'reg arg2loc))
        !           172:           else ; since second is nonsimple, must stack first
        !           173:                ; arg out of harms way
        !           174:                (let ((g-loc 'stack)
        !           175:                      (g-trueop #+(or for-vax for-tahoe) 'jneq #+for-68k 'jne)
        !           176:                      (g-falseop #+(or for-vax for-tahoe) 'jeql #+for-68k 'jeq)
        !           177:                      g-cc
        !           178:                      g-ret)
        !           179:                    (d-exp arg1)
        !           180:                    (push nil g-locs)
        !           181:                    (incr g-loccnt)
        !           182:                    (setq g-loc 'reg)           ; second arg to reg
        !           183:                    (d-exp arg2))
        !           184:                (d-cmp 'unstack 'reg)
        !           185:                (setq g-locs (cdr g-locs))
        !           186:                (decr g-loccnt)))
        !           187:    (d-invert))
        !           188: 
        !           189: ;--- cc-equal :: compile `equal'
        !           190: ;
        !           191: (defun cc-equal nil
        !           192:   (let ((lab1 (d-genlab))
        !           193:        (lab11 (d-genlab))
        !           194:        lab2)
        !           195:        (d-pushargs (cdr v-form))
        !           196:        (e-cmp '(-8 #.np-reg) '(-4 #.np-reg))
        !           197:        (e-gotonil lab1)
        !           198:        (d-calltran 'equal '2)           ; not eq, try equal.
        !           199:        (d-clearreg)
        !           200:        #+(or for-vax for-tahoe) (e-tst (e-cvt 'reg))
        !           201:        #+for-68k (e-cmpnil (e-cvt 'reg))
        !           202:        (e-gotot lab11)         
        !           203:        (if g-loc then (d-move 'Nil g-loc))
        !           204:        (if (cdr g-cc) then (e-goto (cdr g-cc))
        !           205:           else (e-goto (setq lab2 (d-genlab))))
        !           206:        (e-writel lab1)
        !           207:        (e-dropnp 2)
        !           208:        (e-writel lab11)
        !           209:        (if g-loc then (d-move 'T g-loc))
        !           210:        (if (car g-cc) then (e-goto (car g-cc)))
        !           211:        (if lab2 then (e-writel lab2))
        !           212:        (setq g-locs (cddr g-locs))
        !           213:        (setq g-loccnt (- g-loccnt 2))))
        !           214: 
        !           215: ;--- c-errset :: compile an errset expression
        !           216: ;
        !           217: ; the errset has this form: (errset 'value ['tag])
        !           218: ; where tag defaults to t.
        !           219: ;
        !           220: (defun c-errset nil
        !           221:   (let ((g-loc 'reg)
        !           222:        (g-cc nil)
        !           223:        (g-ret nil)
        !           224:        (finlab (d-genlab))
        !           225:        (beglab (d-genlab)))
        !           226:        (d-exp (if (cddr v-form) then (caddr v-form) else t))
        !           227:        (d-pushframe #.F_CATCH (d-loclit 'ER%all nil) 'reg)
        !           228:        (push nil g-labs)               ; disallow labels
        !           229:        ; If retval is non zero then an error has throw us here so we 
        !           230:        ; must recover the value thrown (from _lispretval) and leave
        !           231:        ; If retval is zero then we shoud calculate the expression 
        !           232:        ; into r0  and put a cons cell around it
        !           233:        (e-tst '_retval)
        !           234:        (e-write2 #+(or for-vax for-tahoe) 'jeql #+for-68k 'jeq beglab)
        !           235:        (e-move '_lispretval (e-cvt 'reg))
        !           236:        (e-write2 #+(or for-vax for-tahoe) 'jbr #+for-68k 'jra finlab)
        !           237:        (e-label beglab)
        !           238:        (let ((g-loc 'stack)
        !           239:             (g-cc nil))
        !           240:            (d-exp (cadr v-form)))
        !           241:        (d-move 'Nil 'stack)    ; haven't updated g-loc, g-loccnt but it
        !           242:                                ; shouldn't hurt (famous last words)
        !           243:        (e-quick-call '_qcons)
        !           244:        (e-label finlab)
        !           245:        (d-popframe)
        !           246:        (unpush g-locs)         ; remove (catcherrset . 0)
        !           247:        (unpush g-labs)         ; remove nil
        !           248:        (d-clearreg)))
        !           249: 
        !           250: ;--- cm-fixnum-cxr :: open code a fixnum-cxr expression.
        !           251: ; 
        !           252: ; fixnum-cxr is a compile only hacky function which accesses an element
        !           253: ; of a fixnum space and boxes the resulting fixnum.  It can be used
        !           254: ; for rapid access to user defined structures.
        !           255: ;
        !           256: (defun cm-fixnum-cxr ()
        !           257:   `(internal-fixnum-box (cxr ,@(cdr v-form))))
        !           258: 
        !           259: (defun c-internal-fixnum-box ()
        !           260:   (let ((g-cc nil)
        !           261:        (g-ret nil)
        !           262:        (g-loc '#.fixnum-reg))
        !           263:        #+for-68k (d-regused '#.fixnum-reg)
        !           264:        (d-exp (cadr v-form))
        !           265:        (e-call-qnewint)))
        !           266: 
        !           267: ;--- cc-offset-cxr
        !           268: ; return a pointer to the address of the object instead of the object.
        !           269: ;
        !           270: (defun cc-offset-cxr nil
        !           271:   (d-supercxr nil t))
        !           272: 
        !           273: ;--- cc-fixp :: check for a fixnum or bignum
        !           274: ;
        !           275: (defun cc-fixp nil
        !           276:   (d-typecmplx (cadr v-form) 
        !           277:               '#.(immed-const (plus 1_2 1_9))))
        !           278: 
        !           279: ;--- cc-floatp :: check for a flonum
        !           280: ;
        !           281: (defun cc-floatp nil
        !           282:   (d-typesimp (cadr v-form) #.(immed-const 4)))
        !           283: 
        !           284: ;--- c-funcall :: compile a funcall
        !           285: ;
        !           286: ; we open code a funcall the resulting object is a compiled lambda.
        !           287: ; We don't open code nlambda and macro funcalls since they are
        !           288: ; rarely used and it would waste space to check for them
        !           289: (defun c-funcall nil
        !           290:    (if (null (cdr v-form))
        !           291:       then (comp-err "funcall requires at least one argument " v-form))
        !           292:    (let ((g-locs g-locs)
        !           293:         (g-loccnt g-loccnt)
        !           294:         (args (length (cdr v-form)))
        !           295:         (g-loc nil)
        !           296:         (g-ret nil)
        !           297:         (g-cc nil))
        !           298:       (d-pushargs (cdr v-form))
        !           299:       (rplaca (nthcdr (1- args) g-locs) 'funcallfcn)
        !           300: 
        !           301:       (d-exp '(cond ((and (symbolp funcallfcn)
        !           302:                          (getd funcallfcn))
        !           303:                     (setq funcallfcn (getd funcallfcn)))))
        !           304:             
        !           305:       (d-exp `(cond ((and (bcdp funcallfcn) (eq 'lambda (getdisc funcallfcn)))
        !           306:                        (Internal-bcdcall ,args t))
        !           307:                       (t (Internal-bcdcall  ,args nil))))))
        !           308: 
        !           309: ;--- c-Internal-bcdcall
        !           310: ; this is a compiler internal function call.  when this occurs, there
        !           311: ;  are argnum objects stacked, the first of which is a function name
        !           312: ;  or bcd object.  If dobcdcall is t then we want to do a bcdcall of
        !           313: ;  the first object stacked.  If it is not true then we want to
        !           314: ;  call the interpreter funcall function to handle it.
        !           315: ;
        !           316: (defun c-Internal-bcdcall nil
        !           317:    (let ((argnum (cadr v-form))
        !           318:         (dobcdcall (caddr v-form)))
        !           319:       (cond (dobcdcall (d-bcdcall argnum))
        !           320:            (t (d-calltran 'funcall argnum)))))
        !           321: 
        !           322: ;--- cc-function :: compile a function function
        !           323: ;
        !           324: ; function is an nlambda, which the interpreter treats as 'quote'
        !           325: ; If the argument is a lambda expression, then Liszt will generate
        !           326: ; a new function and generate code to return the name of
        !           327: ; that function.  If the argument is a symbol, then 'symbol
        !           328: ; is compiled.   It would probably be better to return the function
        !           329: ; cell of the symbol, but Maclisp returns the symbol and it
        !           330: ; would cause compatibility problems.
        !           331: ;
        !           332: (defun cc-function nil
        !           333:    (if (or (null (cdr v-form))
        !           334:           (cddr v-form))
        !           335:       then (comp-err "Wrong number of arguments to 'function': " v-form))
        !           336:    (let ((arg (cadr v-form)))
        !           337:       (if (symbolp arg)
        !           338:         then (d-exp `',arg)
        !           339:        elseif (and (dtpr arg)
        !           340:                   (memq (car arg) '(lambda nlambda lexpr)))
        !           341:         then (let ((newname (concat "in-line-lambda:"
        !           342:                                     (setq in-line-lambda-number
        !           343:                                           (add1 in-line-lambda-number)))))
        !           344:                 (Push liszt-process-forms
        !           345:                       `(def ,newname ,arg))
        !           346:                 (d-exp `',newname))
        !           347:         else (comp-err "Illegal argument to 'function': " v-form))))
        !           348: 
        !           349: ;--- c-get :: do a get from the prop list
        !           350: ;
        !           351: (defun c-get nil
        !           352:   (if (not (eq 2 (length (cdr v-form))))
        !           353:       then (comp-err "Wrong number of args to get " v-form))
        !           354:   (d-pushargs (cdr v-form))            ; there better be 2 args
        !           355:   (e-quick-call '_qget)
        !           356:   (d-clearreg)
        !           357:   (setq g-locs (cddr g-locs))
        !           358:   (setq g-loccnt (- g-loccnt 2)))
        !           359: 
        !           360: ;--- cm-getaccess :: compile a getaccess instruction
        !           361: ;
        !           362: (defun cm-getaccess nil `(cdr ,(cadr v-form)))
        !           363: 
        !           364: ;--- cm-getaux :: compile a getaux instruction
        !           365: ;
        !           366: (defun cm-getaux  nil `(car ,(cadr v-form)))
        !           367: 
        !           368: ;--- cm-getd :: compile a getd instruction
        !           369: ;
        !           370: ; the getd function is open coded to look in the third part of a symbol
        !           371: ; cell
        !           372: ;
        !           373: (defun cm-getd nil `(cxr 2 ,(cadr v-form)))
        !           374: 
        !           375: ;--- cm-getdata :: compile a getdata instruction
        !           376: ;
        !           377: ; the getdata function is open coded to look in the third part of an 
        !           378: ; array header.
        !           379: (defun cm-getdata nil `(cxr 2 ,(cadr v-form)))
        !           380: 
        !           381: ;--- cm-getdisc  :: compile a getdisc expression
        !           382: ; getdisc accessed the discipline field of a binary object.
        !           383: ;
        !           384: (defun cm-getdisc nil `(cxr 1 ,(cadr v-form)))
        !           385: 
        !           386: ;--- c-go :: compile a "go" expression
        !           387: ;
        !           388: ; we only compile the (go symbol)type expression, we do not
        !           389: ; allow symbol to be anything by a non null symbol.
        !           390: ;
        !           391: (defun c-go nil
        !           392:    ; find number of frames we have to go down to get to the label
        !           393:    (do ((labs g-labs (cdr labs))
        !           394:        (locs g-locs)
        !           395:        (locals 0)
        !           396:        (specials 0)
        !           397:        (catcherrset 0)
        !           398:        (label))
        !           399:        ((null labs)
        !           400:        (comp-err "go label not found for expression: " (or v-form)))
        !           401: 
        !           402:        (if (car labs)          ; if we have a set of labels to look at...
        !           403:           then (if (setq label
        !           404:                          (do ((lbs (cdar labs) (cdr lbs)))
        !           405:                              ((null lbs))
        !           406:                              (if (eq (caar lbs) (cadr v-form))
        !           407:                                  then (return (cdar lbs)))))
        !           408:                    then (if (not (eq labs g-labs))
        !           409:                             then (comp-note g-fname ": non local go used : "
        !           410:                                             (or v-form)))
        !           411:                         ; three stack to pop: namestack, bindstack
        !           412:                         ;   and execution stack
        !           413:                         (e-pop locals)
        !           414:                         (if (greaterp specials 0)
        !           415:                             then (e-unshallowbind specials))
        !           416:                         (if (greaterp catcherrset 0)
        !           417:                             then (comp-note g-fname
        !           418:                                             ": Go through a catch or errset "
        !           419:                                             v-form)
        !           420:                                  (do ((i 0 (1+ i)))
        !           421:                                      ((=& catcherrset i))
        !           422:                                      (d-popframe)))
        !           423:                         (e-goto label)
        !           424:                         (return)))
        !           425:        ; tally all locals, specials and catcherrsets used in this frame
        !           426:        (do ()
        !           427:           ((dtpr (car locs))
        !           428:            (if (eq 'catcherrset (caar locs))
        !           429:               then (incr catcherrset)
        !           430:             elseif (eq 'progv (caar locs))
        !           431:               then (comp-err "Attempt to 'go' through a progv"))
        !           432:            (setq specials (+ specials (cdar locs))
        !           433:                  locs (cdr locs)))
        !           434:           (setq locs (cdr locs))
        !           435:           (incr locals))))
        !           436:                        
        !           437: ;--- cc-ignore :: just ignore this code
        !           438: ;
        !           439: (defun cc-ignore nil
        !           440:   nil)
        !           441: 
        !           442: ;--- c-lambexp :: compile a lambda expression
        !           443: ;
        !           444: (defun c-lambexp nil
        !           445:   (let ((g-loc (if (or g-loc g-cc) then 'reg))
        !           446:        (g-cc nil)
        !           447:        (g-locs (cons (cons 'lambda 0) g-locs))
        !           448:        (g-labs (cons nil g-labs)))
        !           449:        (d-pushargs (cdr v-form))               ; then push vals
        !           450:        (d-lambbody (car v-form))
        !           451:        (d-clearreg)))
        !           452: 
        !           453: ;--- d-lambbody :: do a lambda body
        !           454: ;      - body : body of lambda expression, eg (lambda () dld)
        !           455: ;
        !           456: (defun d-lambbody (body)
        !           457:    (let ((g-decls g-decls))
        !           458:       (d-scanfordecls (cddr body))             ; look for declarations
        !           459:       (d-bindlamb (cadr body))         ; bind locals
        !           460:       (d-clearreg)
        !           461:       (d-exp (do ((ll (cddr body) (cdr ll))
        !           462:                  (g-loc)
        !           463:                  (g-cc)
        !           464:                  (g-ret))
        !           465:                 ((null (cdr ll)) (car ll))
        !           466:                 (d-exp (car ll))))
        !           467: 
        !           468:       (d-unbind)))                             ; unbind this frame
        !           469: 
        !           470: ;--- d-bindlamb :: bind  variables in lambda list
        !           471: ;      - vrbs : list of lambda variables, may include nil meaning ignore
        !           472: ;
        !           473: (defun d-bindlamb (vrbs)
        !           474:   (let ((res (d-bindlrec (reverse vrbs) g-locs 0 g-loccnt)))
        !           475:        (if res then (e-setupbind)
        !           476:                    (mapc '(lambda (vrb) (e-shallowbind (car vrb) (cdr vrb)))
        !           477:                          res)
        !           478:                    (e-unsetupbind))))
        !           479:   
        !           480: ;--- d-bindlrec :: recusive routine to bind lambda variables
        !           481: ;      - vrb : list of variables yet to bind
        !           482: ;      - locs : current location in g-loc
        !           483: ;      - specs : number of specials seen so far
        !           484: ;      - lev  : how far up from the bottom of stack we are.
        !           485: ; returns: list of elements, one for each special, of this form:
        !           486: ;              (<specialvrbname> stack <n>)
        !           487: ;      where specialvrbname is the name of the special variable, and n is
        !           488: ;      the distance from the top of the stack where its initial value is 
        !           489: ;      located
        !           490: ; also: puts the names of the local variables in the g-locs list, as well
        !           491: ;      as placing the number of special variables in the lambda header.
        !           492: ;
        !           493: (defun d-bindlrec (vrb locs specs lev)
        !           494:    (if vrb 
        !           495:        then (let ((spcflg (d-specialp (car vrb)))
        !           496:                  retv)
        !           497:                (if spcflg then (setq specs (1+ specs)))
        !           498: 
        !           499:                (if (cdr vrb)           ; if more vrbls to go ...
        !           500:                    then (setq retv (d-bindlrec (cdr vrb)
        !           501:                                                (cdr locs)
        !           502:                                                specs
        !           503:                                                (1- lev)))
        !           504:                    else (rplacd (cadr locs)
        !           505:                                 specs))        ; else fix up lambda hdr
        !           506: 
        !           507:                (if (not spcflg) then (rplaca locs (car vrb))
        !           508:                    else (Push retv `(,(car vrb) stack ,lev)))
        !           509: 
        !           510:                retv)))
        !           511: 
        !           512: ;--- d-scanfordecls
        !           513: ; forms - the body of a lambda, prog or do.
        !           514: ;  we look down the form for 'declare' forms.  They should be at the
        !           515: ;  beginning, but there are macros which may unintentionally put forms
        !           516: ;  in front of user written forms.  Thus we check a little further than
        !           517: ;  the first form.
        !           518: (defun d-scanfordecls (forms)
        !           519:    ; look for declarations in the first few forms
        !           520:    (do ((count 3 (1- count)))
        !           521:        ((= 0 count))
        !           522:        (cond ((and (dtpr (car forms))
        !           523:                   (eq 'declare (caar forms))
        !           524:                   (apply 'liszt-declare (cdar forms)))))
        !           525:        (setq forms (cdr forms))))
        !           526: 
        !           527: ;--- c-list :: compile a list expression
        !           528: ;
        !           529: ; this is compiled as a bunch of conses with a nil pushed on the
        !           530: ; top for good measure
        !           531: ;
        !           532: (defun c-list nil
        !           533:   (prog (nargs)
        !           534:        (setq nargs (length (cdr v-form)))
        !           535:        (makecomment '(list expression))
        !           536:        (if (zerop nargs)
        !           537:            then (d-move 'Nil 'reg)     ; (list) ==> nil
        !           538:                 (return))
        !           539:        (d-pushargs (cdr v-form))
        !           540:        #+(or for-vax for-tahoe) (e-write2 'clrl '#.np-plus) ; stack one nil
        !           541:        #+for-68k (L-push (e-cvt 'Nil))
        !           542: 
        !           543:        ; now do the consing
        !           544:        (do ((i (max 1 nargs) (1- i)))
        !           545:           ((zerop i))
        !           546:           (e-quick-call '_qcons)
        !           547:           (d-clearreg)
        !           548:           (if (> i 1) then (L-push (e-cvt 'reg))))
        !           549: 
        !           550:        (setq g-locs (nthcdr nargs g-locs)
        !           551:             g-loccnt (- g-loccnt nargs))))
        !           552: 
        !           553: ;--- d-mapconvert - access : function to access parts of lists
        !           554: ;                - join         : function to join results
        !           555: ;                - resu         : function to apply to result
        !           556: ;                - form         : mapping form
        !           557: ;      This function converts maps to an equivalent do form.
        !           558: ;
        !           559: ;  in this function, the variable vrbls contains a list of forms, one form
        !           560: ;  per list we are mapping over.  The form of the form is 
        !           561: ;    (dummyvariable  realarg  (cdr dummyvariable))
        !           562: ; realarg may be surrounded by (setq <variable which holds result> realarg)
        !           563: ; in the case that the result is the list to be mapped over (this only occurs
        !           564: ; with the function mapc).
        !           565: ;
        !           566: (defun d-mapconvert (access join resu form )
        !           567:    (prog (vrbls finvar acc accform compform
        !           568:                tmp testform tempvar lastvar)
        !           569: 
        !           570:        (setq finvar (gensym 'X)   ; holds result
        !           571: 
        !           572:             vrbls
        !           573:             (reverse
        !           574:                 (maplist '(lambda (arg)
        !           575:                               ((lambda (temp)
        !           576:                                    (cond ((or resu (cdr arg))
        !           577:                                           `(,temp ,(car arg)
        !           578:                                              (cdr ,temp)))
        !           579:                                          (t `(,temp
        !           580:                                                (setq ,finvar
        !           581:                                                       ,(car arg))
        !           582:                                                (cdr ,temp)))))
        !           583:                                (gensym 'X)))
        !           584:                          (reverse (cdr form))))
        !           585: 
        !           586:             ; the access form will either be nil or car.  If it is
        !           587:             ; nil, then we are doing something like a maplist,
        !           588:             ; if the access form is car, then we are doing something
        !           589:             ; like a mapcar.
        !           590:             acc (mapcar '(lambda (tem)
        !           591:                              (cond (access `(,access ,(car tem)))
        !           592:                                    (t (car tem))))
        !           593:                         vrbls)
        !           594: 
        !           595:             accform (cond ((or (atom (setq tmp (car form)))
        !           596:                                (null (setq tmp (d-macroexpand tmp)))
        !           597:                                (not (member (car tmp) '(quote function))))
        !           598:                            `(funcall ,tmp ,@acc))
        !           599:                           (t `(,(cadr tmp) ,@acc)))
        !           600: 
        !           601:             ; the testform checks if any of the lists we are mapping
        !           602:             ; over is nil, in which case we quit.
        !           603:             testform (cond ((null (cdr vrbls)) `(null ,(caar vrbls)))
        !           604:                            (t `(or ,@(mapcar '(lambda (x)
        !           605:                                                   `(null ,(car  x)))
        !           606:                                              vrbls)))))
        !           607: 
        !           608:        ; in the case of mapcans and mapcons, you need two
        !           609:        ; extra variables to simulate the nconc.
        !           610:        ; testvar gets intermediate results and lastvar
        !           611:        ; points to then end of the list
        !           612:        (if (eq join 'nconc)
        !           613:           then (setq tempvar (gensym 'X)
        !           614:                      lastvar (gensym 'X)
        !           615:                      vrbls `((,tempvar) (,lastvar) ,@vrbls)))
        !           616: 
        !           617:        (return
        !           618:           `((lambda
        !           619:                 (,finvar)
        !           620:                 (liszt-internal-do
        !           621:                     ( ,@vrbls)
        !           622:                     (,testform)
        !           623:                     ,(cond ((eq join 'nconc)
        !           624:                             `(cond ((setq ,tempvar ,accform)
        !           625:                                     (cond (,lastvar
        !           626:                                             (liszt-internal-do
        !           627:                                                 ()
        !           628:                                                 ((null (cdr ,lastvar)))
        !           629:                                                 (setq ,lastvar
        !           630:                                                       (cdr ,lastvar)))
        !           631:                                             (rplacd ,lastvar ,tempvar))
        !           632:                                           (t (setq ,finvar
        !           633:                                                     (setq ,lastvar
        !           634:                                                           ,tempvar)))))))
        !           635:                            (join `(setq ,finvar (,join ,accform ,finvar)))
        !           636:                            (t accform)))
        !           637:                 ,(cond ((eq resu 'identity) finvar)
        !           638:                        (resu `(,resu ,finvar))
        !           639:                        (t finvar)))
        !           640:             nil ))))
        !           641: 
        !           642: ; apply to successive elements, return second arg
        !           643: (defun cm-mapc nil
        !           644:          (d-mapconvert 'car nil nil (cdr v-form)))
        !           645: 
        !           646: ; apply to successive elements, return list of results
        !           647: (defun cm-mapcar nil
        !           648:          (d-mapconvert 'car 'cons 'nreverse (cdr v-form)))
        !           649: 
        !           650: ; apply to successive elements, returned nconc of results
        !           651: (defun cm-mapcan nil
        !           652:          (d-mapconvert 'car 'nconc 'identity (cdr v-form)))
        !           653: 
        !           654: ; apply to successive sublists, return second arg
        !           655: (defun cm-map nil
        !           656:          (d-mapconvert nil nil nil (cdr v-form)))
        !           657: 
        !           658: ; apply to successive sublists, return list of results
        !           659: (defun cm-maplist nil
        !           660:          (d-mapconvert nil 'cons 'reverse (cdr v-form)))
        !           661: 
        !           662: ; apply to successive sublists, return nconc of results
        !           663: (defun cm-mapcon nil
        !           664:          (d-mapconvert nil 'nconc 'identity (cdr v-form)))
        !           665: 
        !           666: ;--- cc-memq :: compile a memq expression
        !           667: ;
        !           668: #+(or for-vax for-tahoe)
        !           669: (defun cc-memq nil
        !           670:   (let ((loc1 (d-simple (cadr v-form)))
        !           671:        (loc2 (d-simple (caddr v-form)))
        !           672:        looploc finlab)
        !           673:        (if loc2
        !           674:           then (d-clearreg 'r1)
        !           675:                (if loc1
        !           676:                    then (d-move loc1 'r1)
        !           677:                    else (let ((g-loc 'r1)
        !           678:                               g-cc
        !           679:                               g-ret)
        !           680:                             (d-exp (cadr v-form))))
        !           681:                (d-move loc2 'reg)
        !           682:           else (let ((g-loc 'stack)
        !           683:                      g-cc
        !           684:                      g-ret)
        !           685:                    (d-exp (cadr v-form)))
        !           686:                (push nil g-locs)
        !           687:                (incr g-loccnt)
        !           688:                (let ((g-loc 'reg)
        !           689:                      g-cc
        !           690:                      g-ret)
        !           691:                    (d-exp (caddr v-form)))
        !           692:                (L-pop 'r1)
        !           693:                (d-clearreg 'r1)
        !           694:                (unpush g-locs)
        !           695:                (decr g-loccnt))
        !           696:        ; now set up the jump addresses
        !           697:        (if (null g-loc)
        !           698:           then (setq loc1 (if (car g-cc) thenret else (d-genlab))
        !           699:                      loc2 (if (cdr g-cc) thenret else (d-genlab)))
        !           700:           else (setq loc1 (d-genlab)
        !           701:                      loc2 (d-genlab)))
        !           702: 
        !           703:        (setq looploc (d-genlab))
        !           704:        (e-tst 'r0)
        !           705:        (e-write2 'jeql loc2)
        !           706:        (e-label looploc)
        !           707:        (e-cmp 'r1 '(4 r0))
        !           708:        (e-write2 'jeql loc1)
        !           709:        (e-move '(0 r0) 'r0)
        !           710:        (e-write2 'jneq looploc)
        !           711:        (if g-loc
        !           712:           then (e-label loc2)          ; nil result
        !           713:                (d-move 'reg g-loc)
        !           714:                (if (cdr g-cc)
        !           715:                    then (e-goto (cdr g-cc))
        !           716:                    else (e-goto (setq finlab (d-genlab))))
        !           717:           else (if (cdr g-cc)
        !           718:                    then (e-goto (cdr g-cc))
        !           719:                    else (e-label loc2)))
        !           720:        (if g-loc
        !           721:           then (e-label loc1)          ; non nil result
        !           722:                (d-move 'reg g-loc)
        !           723:                (if (car g-cc) then (e-goto (car g-cc)))
        !           724:           else (if (null (car g-cc)) then (e-label loc1)))
        !           725:        (if finlab then (e-label finlab))))
        !           726: 
        !           727: #+for-68k
        !           728: (defun cc-memq nil
        !           729:    (let ((loc1 (d-simple (cadr v-form)))
        !           730:         (loc2 (d-simple (caddr v-form)))
        !           731:         looploc finlab
        !           732:         (tmp-data-reg (d-alloc-register 'd nil)))
        !           733:        (d-clearreg tmp-data-reg)
        !           734:        (d-clearreg 'a0)
        !           735:        (if loc2
        !           736:           then (if loc1
        !           737:                    then (d-move loc1 tmp-data-reg)
        !           738:                    else (let ((g-loc tmp-data-reg)
        !           739:                               g-cc
        !           740:                               g-ret)
        !           741:                             (d-exp (cadr v-form))))
        !           742:                (d-move loc2 'reg)
        !           743:           else (let ((g-loc 'stack)
        !           744:                      g-cc
        !           745:                      g-ret)
        !           746:                    (d-exp (cadr v-form)))
        !           747:                (push nil g-locs)
        !           748:                (incr g-loccnt)
        !           749:                (let ((g-loc 'reg)
        !           750:                      g-cc
        !           751:                      g-ret)
        !           752:                    (d-exp (caddr v-form)))
        !           753:                (L-pop tmp-data-reg)
        !           754:                (unpush g-locs)
        !           755:                (decr g-loccnt))
        !           756:        ; now set up the jump addresses
        !           757:        (if (null g-loc)
        !           758:           then (setq loc1 (if (car g-cc) thenret else (d-genlab))
        !           759:                      loc2 (if (cdr g-cc) thenret else (d-genlab)))
        !           760:           else (setq loc1 (d-genlab)
        !           761:                      loc2 (d-genlab)))
        !           762:        (setq looploc (d-genlab))
        !           763:        (e-cmpnil 'd0)
        !           764:        (e-write2 'jeq loc2)
        !           765:        (e-move 'd0 'a0)
        !           766:        (e-label looploc)
        !           767:        (e-cmp tmp-data-reg '(4 a0))
        !           768:        (e-write2 'jeq loc1)
        !           769:        (e-move '(0 a0) 'a0)
        !           770:        (e-cmpnil 'a0)
        !           771:        (e-write2 'jne looploc)
        !           772:        (e-move 'a0 'd0)
        !           773:        (if g-loc
        !           774:           then (e-label loc2)                  ; nil result
        !           775:                (d-move 'reg g-loc)
        !           776:                (if (cdr g-cc)
        !           777:                    then (e-goto (cdr g-cc))
        !           778:                    else (e-goto (setq finlab (d-genlab))))
        !           779:           else (if (cdr g-cc)
        !           780:                    then (e-goto (cdr g-cc))
        !           781:                    else (e-label loc2)))
        !           782:        (if g-loc
        !           783:           then (e-label loc1)                  ; non nil result
        !           784:                (d-move 'a0 g-loc)              ;a0 was cdr of non-nil result
        !           785:                (if (car g-cc) then (e-goto (car g-cc)))
        !           786:           else (if (null (car g-cc)) then (e-label loc1)))
        !           787:        (if finlab then (e-label finlab))))

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