Return to func.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt

Annotation of 42BSD/ucb/lisp/liszt/func.l, revision 1.1

1.1     ! root        1: (include-if (null (get 'chead 'version)) "../chead.l")
        !             2: (Liszt-file func
        !             3:    "$Header: func.l,v 1.12 83/08/28 17:12:47 layer Exp $")
        !             4: 
        !             5: ;;; ----       f u n c                         function compilation
        !             6: ;;;
        !             7: ;;;                    -[Wed Aug 24 10:51:11 1983 by layer]-
        !             8: 
        !             9: ; cm-ncons :: macro out an ncons expression
        !            10: ;
        !            11: (defun cm-ncons nil
        !            12:   `(cons ,(cadr v-form) nil))
        !            13: 
        !            14: ; cc-not :: compile a "not" or "null" expression
        !            15: ;
        !            16: (defun cc-not nil
        !            17:   (makecomment '(beginning not))
        !            18:   (if (null g-loc)
        !            19:       then (let ((g-cc (cons (cdr g-cc) (car g-cc)))
        !            20:                 (g-ret nil))
        !            21:                (d-exp (cadr v-form)))
        !            22:       else (let ((finlab (d-genlab))
        !            23:                 (finlab2 (d-genlab))
        !            24:                 (g-ret nil))
        !            25:                ; eval arg and jump to finlab if nil
        !            26:                (let ((g-cc (cons finlab nil))
        !            27:                      g-loc)
        !            28:                     (d-exp (cadr v-form)))
        !            29:                ; didn't jump, answer must be t
        !            30:                (d-move 'T g-loc)
        !            31:                (if (car g-cc)
        !            32:                    then (e-goto (car g-cc))
        !            33:                    else (e-goto finlab2))
        !            34:                (e-label finlab)
        !            35:                ; answer is nil
        !            36:                (d-move 'Nil g-loc)
        !            37:                (if (cdr g-cc) then (e-goto (cdr g-cc)))
        !            38:                (e-label finlab2))))
        !            39: 
        !            40: ;--- cc-numberp :: check for numberness
        !            41: ;
        !            42: (defun cc-numberp nil
        !            43:   (d-typecmplx (cadr v-form) 
        !            44:               '#.(immed-const (plus 1_2 1_4 1_9))))
        !            45: 
        !            46: ;--- cc-or :: compile an "or" expression
        !            47: ;
        !            48: (defun cc-or nil
        !            49:   (let ((finlab (d-genlab))
        !            50:        (finlab2)
        !            51:        (exps (if (cdr v-form) thenret else '(nil)))) ; (or) => nil
        !            52:        (if (null (car g-cc))
        !            53:           then (d-exp (do ((g-cc (cons finlab nil))
        !            54:                            (g-loc (if g-loc then 'reg))
        !            55:                            (g-ret nil)
        !            56:                            (ll exps (cdr ll)))
        !            57:                           ((null (cdr ll)) (car ll))
        !            58:                           (d-exp (car ll))))
        !            59:                (if g-loc
        !            60:                    then (setq finlab2 (d-genlab))
        !            61:                         (e-goto finlab2)
        !            62:                         (e-label finlab)
        !            63:                         (d-move 'reg g-loc)
        !            64:                         (e-label finlab2)
        !            65:                    else (e-label finlab))
        !            66:           else (if (null g-loc) then (setq finlab (car g-cc)))
        !            67:                (d-exp (do ((g-cc (cons finlab nil))
        !            68:                            (g-loc (if g-loc then 'reg))
        !            69:                            (g-ret nil)
        !            70:                            (ll exps (cdr ll)))
        !            71:                           ((null (cdr ll)) (car ll))
        !            72:                           (d-exp (car ll))))
        !            73:                (if g-loc
        !            74:                    then (setq finlab2 (d-genlab))
        !            75:                         (e-goto finlab2)
        !            76:                         (e-label finlab)
        !            77:                         (d-move 'reg g-loc)
        !            78:                         (e-goto (car g-cc))    ; result is t
        !            79:                         (e-label finlab2)))
        !            80:        (d-clearreg)))  ;we are not sure of the state due to possible branches.
        !            81:                               
        !            82: ;--- c-prog :: compile a "prog" expression
        !            83: ;
        !            84: ; for interlisp compatibility, we allow the formal variable list to
        !            85: ; contain objects of this form (vrbl init) which gives the initial value
        !            86: ; for that variable (instead of nil)
        !            87: ;
        !            88: (defun c-prog nil
        !            89:    (let ((g-decls g-decls))
        !            90:       (let (g-loc g-cc seeninit initf
        !            91:            (p-rettrue g-ret) (g-ret nil)
        !            92:            ((spcs locs initsv . initsn) (d-classify (cadr v-form))))
        !            93: 
        !            94:         (e-pushnil (length locs))      ; locals initially nil
        !            95:         (d-bindprg spcs locs)          ; bind locs and specs
        !            96: 
        !            97:         (cond (initsv (d-pushargs initsv)
        !            98:                       (mapc '(lambda (x)
        !            99:                                 (d-move 'unstack (d-loc x))
        !           100:                                 (decr g-loccnt)
        !           101:                                 (unpush g-locs))
        !           102:                             (nreverse initsn))))
        !           103: 
        !           104:         ; determine all possible labels
        !           105:         (do ((ll (cddr v-form) (cdr ll))
        !           106:              (labs nil))
        !           107:             ((null ll) (setq g-labs `((,(d-genlab) ,@labs)
        !           108:                                       ,@g-labs)))
        !           109:             (if (and (car ll) (symbolp (car ll)))
        !           110:                then (if (assq (car ll) labs)
        !           111:                        then (comp-err "label is mulitiply defined " (car ll))
        !           112:                        else (setq labs (cons (cons (car ll) (d-genlab))
        !           113:                                              labs)))))
        !           114: 
        !           115:         ; compile each form which is not a label
        !           116:         (d-clearreg)           ; unknown state after binding
        !           117:         (do ((ll (cddr v-form) (cdr ll)))
        !           118:             ((null ll))
        !           119:             (if (or (null (car ll)) (not (symbolp (car ll))))
        !           120:                then (d-exp (car ll))
        !           121:                else (e-label (cdr (assq (car ll) (cdar g-labs))))
        !           122:                     (d-clearreg))))            ; dont know state after label
        !           123: 
        !           124:       ; result is nil if fall out and care about value
        !           125:       (if (or g-cc g-loc) then (d-move 'Nil 'reg))
        !           126: 
        !           127:       (e-label (caar g-labs))          ; return to label
        !           128:       (setq g-labs (cdr g-labs))
        !           129:       (d-unbind)))                     ; unbind our frame
        !           130: 
        !           131: ;--- d-bindprg :: do binding for a prog expression
        !           132: ;      - spcs : list of special variables
        !           133: ;      - locs : list of local variables
        !           134: ;      - specinit : init values for specs (or nil if all are nil)
        !           135: ;
        !           136: (defun d-bindprg (spcs locs)
        !           137:    ; place the local vrbls and prog frame entry on the stack
        !           138:    (setq g-loccnt (+ g-loccnt (length locs))
        !           139:         g-locs (nconc locs `((prog . ,(length spcs)) ,@g-locs)))
        !           140: 
        !           141:    ; now bind the specials, if any, to nil
        !           142:    (if spcs then (e-setupbind)
        !           143:        (mapc '(lambda (vrb)
        !           144:                  (e-shallowbind vrb 'Nil))
        !           145:             spcs)
        !           146:        (e-unsetupbind)))
        !           147: 
        !           148: ;--- d-unbind :: remove one frame from g-locs
        !           149: ;
        !           150: (defun d-unbind nil
        !           151:    (do ((count 0 (1+ count)))
        !           152:        ((dtpr (car g-locs))
        !           153:        (if (not (zerop (cdar g-locs)))
        !           154:            then (e-unshallowbind (cdar g-locs)))
        !           155:        (cond ((not (zerop count))
        !           156:               (e-dropnp count)
        !           157: 
        !           158:               (setq g-loccnt (- g-loccnt count))))
        !           159:        (setq g-locs (cdr g-locs)))
        !           160:        (setq g-locs (cdr g-locs))))
        !           161:        
        !           162: ;--- d-classify :: seperate variable list into special and non-special
        !           163: ;      - lst : list of variables
        !           164: ; returns ( xxx yyy zzz . aaa) 
        !           165: ;              where xxx is the list of special variables and
        !           166: ;              yyy is the list of local variables
        !           167: ;              zzz are the non nil initial values for prog variables
        !           168: ;              aaa are the names corresponding to the values in zzz
        !           169: ;
        !           170: (defun d-classify (lst)
        !           171:    (do ((ll lst (cdr ll))
        !           172:        (locs) (spcs) (init) (initsv) (initsn)
        !           173:        (name))
        !           174:        ((null ll) (cons spcs (cons locs (cons initsv initsn))))
        !           175:        (if (atom (car ll))
        !           176:           then (setq name (car ll))
        !           177:           else (setq name (caar ll))
        !           178:                (push name initsn)
        !           179:                (push (cadar ll) initsv))
        !           180:        (if (d-specialp name)
        !           181:           then (push name spcs)
        !           182:           else (push name locs))))
        !           183: 
        !           184: ; cm-progn :: compile a "progn" expression
        !           185: ;
        !           186: (defun cm-progn nil
        !           187:   `((lambda nil ,@(cdr v-form))))
        !           188: 
        !           189: ; cm-prog1 :: compile a "prog1" expression
        !           190: ;
        !           191: (defun cm-prog1 nil
        !           192:   (let ((gl (d-genlab)))
        !           193:        `((lambda (,gl) 
        !           194:                 ,@(cddr v-form)
        !           195:                 ,gl)
        !           196:         ,(cadr v-form))))
        !           197: 
        !           198: ; cm-prog2 :: compile a "prog2" expression
        !           199: ;
        !           200: (defun cm-prog2 nil
        !           201:    (let ((gl (d-genlab)))
        !           202:        `((lambda (,gl)
        !           203:             ,(cadr v-form)
        !           204:             (setq ,gl ,(caddr v-form))
        !           205:             ,@(cdddr v-form)
        !           206:             ,gl)
        !           207:         nil)))
        !           208: 
        !           209: ;--- cm-progv :: compile a progv form
        !           210: ;  a progv form looks like (progv 'l-vars 'l-inits 'g-exp1 ... 'g-expn)
        !           211: ; l-vars should be a list of variables, l-inits a list of initial forms
        !           212: ; We cannot permit returns and go-s through this form.
        !           213: ;
        !           214: ; we stack a (progv . 0) form on g-locs so that return and go will know
        !           215: ; not to try to go through this form.
        !           216: ;
        !           217: (defun c-progv nil
        !           218:    (let ((gl (d-genlab))
        !           219:         (g-labs (cons nil g-labs))
        !           220:         (g-locs (cons '(progv . 0) g-locs)))
        !           221:        (d-exp `((lambda (,gl)
        !           222:                    (prog1 (progn ,@(cdddr v-form))
        !           223:                           (internal-unbind-vars ,gl)))
        !           224:                (internal-bind-vars ,(cadr v-form) ,(caddr v-form))))))
        !           225: 
        !           226: (defun c-internal-bind-vars nil
        !           227:    (let ((g-locs g-locs)
        !           228:         (g-loccnt g-loccnt))
        !           229:        (d-pushargs (cdr v-form))
        !           230:        (d-calldirect '_Ibindvars (length (cdr v-form)))))
        !           231: 
        !           232: (defun c-internal-unbind-vars nil
        !           233:    (let ((g-locs g-locs)
        !           234:         (g-loccnt g-loccnt))
        !           235:        (d-pushargs (cdr v-form))
        !           236:        (d-calldirect '_Iunbindvars (length (cdr v-form)))))
        !           237: 
        !           238: ;--- cc-quote : compile a "quote" expression
        !           239: ; 
        !           240: ; if we are just looking to set the ; cc, we just make sure 
        !           241: ; we set the cc depending on whether the expression quoted is
        !           242: ; nil or not.
        !           243: (defun cc-quote nil
        !           244:    (let ((arg (cadr v-form))
        !           245:         argloc)
        !           246:        (if (null g-loc) 
        !           247:           then (if (and (null arg) (cdr g-cc))
        !           248:                    then (e-goto (cdr g-cc))
        !           249:                 elseif (and arg (car g-cc))
        !           250:                    then (e-goto (car g-cc))
        !           251:                 elseif (null g-cc)
        !           252:                    then (comp-warn "losing the value of this expression "
        !           253:                                    (or v-form)))
        !           254:           else (d-move (d-loclit arg nil) g-loc)
        !           255:                (d-handlecc))))
        !           256: 
        !           257: ;--- c-setarg :: set a lexpr's arg
        !           258: ; form is (setarg index value)
        !           259: ;
        !           260: (defun c-setarg nil
        !           261:    (if (not (eq 'lexpr g-ftype))
        !           262:        then (comp-err "setarg only allowed in lexprs"))
        !           263:    (if (and fl-inter (eq (length (cdr v-form)) 3))     ; interlisp setarg
        !           264:        then (if (not (eq (cadr v-form) (car g-args)))
        !           265:                then (comp-err "setarg: can only compile local setargs "
        !           266:                               v-form)
        !           267:                else (setq v-form (cdr v-form))))
        !           268:    ; compile index into fixnum-reg, was (d-pushargs (list (cadr v-form)))
        !           269:    (let ((g-cc) (g-ret)
        !           270:         (g-loc '#.fixnum-reg))
        !           271:        (d-exp (cadr v-form)))
        !           272:    (let ((g-loc 'reg)
        !           273:         (g-cc nil)
        !           274:         (g-ret nil))
        !           275:        (d-exp (caddr v-form)))
        !           276:    #+for-vax
        !           277:    (progn
        !           278:        (e-sub3 `(* -4 #.olbot-reg) '(0 #.fixnum-reg) '#.fixnum-reg)
        !           279:        (e-move 'r0 '(-8 #.olbot-reg #.fixnum-reg)))
        !           280:    #+for-68k
        !           281:    (progn
        !           282:        (e-sub `(-4 #.olbot-reg) '#.fixnum-reg)
        !           283:        (e-write3 'lea '(% -8 #.olbot-reg #.fixnum-reg) 'a5)
        !           284:        (e-move 'd0 '(0 a5))))
        !           285: 
        !           286: ;--- cc-stringp :: check for string ness
        !           287: ;
        !           288: (defun cc-stringp nil
        !           289:   (d-typesimp (cadr v-form) #.(immed-const 0)))
        !           290: 
        !           291: ;--- cc-symbolp :: check for symbolness
        !           292: ;
        !           293: (defun cc-symbolp nil
        !           294:   (d-typesimp (cadr v-form) #.(immed-const 1)))
        !           295: 
        !           296: ;--- c-return :: compile a "return" statement
        !           297: ;
        !           298: (defun c-return nil
        !           299:    ; value is always put in reg
        !           300:    (let ((g-loc 'reg)
        !           301:         g-cc
        !           302:         g-ret)
        !           303:        (d-exp (cadr v-form)))
        !           304: 
        !           305:    ; if we are doing a non local return, compute number of specials to unbind
        !           306:    ; and locals to pop
        !           307:    (if (car g-labs)
        !           308:        then (e-goto (caar g-labs))
        !           309:        else (do ((loccnt 0)            ;; locals
        !           310:                 (speccnt 0)            ;; special
        !           311:                 (catcherrset 0)                ;; catch/errset frames
        !           312:                 (ll g-labs (cdr ll))
        !           313:                 (locs g-locs))
        !           314:                ((null ll) (comp-err "return used not within a prog or do"))
        !           315:                (if (car ll)
        !           316:                    then  (comp-note g-fname ": non local return used ")
        !           317:                         ; unbind down to but not including
        !           318:                         ; this frame.
        !           319:                         (if (greaterp loccnt 0)
        !           320:                             then (e-pop loccnt))
        !           321:                         (if (greaterp speccnt 0)
        !           322:                             then (e-unshallowbind speccnt))
        !           323:                         (if (greaterp catcherrset 0)
        !           324:                             then (comp-note
        !           325:                                      g-fname
        !           326:                                      ": return through a catch or errset"
        !           327:                                      v-form)
        !           328:                                  (do ((i 0 (1+ i)))
        !           329:                                      ((=& catcherrset i))
        !           330:                                      (d-popframe)))
        !           331:                         (e-goto (caar ll))
        !           332:                         (return)
        !           333:                    else ; determine number of locals and special on
        !           334:                         ; stack for this frame, add to running
        !           335:                         ; totals
        !           336:                         (do ()
        !           337:                             ((dtpr (car locs))
        !           338:                              (if (eq 'catcherrset (caar locs)) ; catchframe
        !           339:                                  then (incr catcherrset)
        !           340:                               elseif (eq 'progv (caar locs))
        !           341:                                  then (comp-err "Attempt to 'return' through a progv"))
        !           342:                              (setq speccnt (+ speccnt (cdar locs))
        !           343:                                    locs (cdr locs)))
        !           344:                             (incr loccnt)
        !           345:                             (setq locs (cdr locs)))))))
        !           346:         
        !           347: ; c-rplaca :: compile a "rplaca" expression
        !           348: ;
        !           349: #+for-vax
        !           350: (defun c-rplaca nil
        !           351:   (let ((ssimp (d-simple (caddr v-form)))
        !           352:        (g-ret nil))
        !           353:        (let ((g-loc (if ssimp then 'reg else 'stack))
        !           354:             (g-cc nil))
        !           355:            (d-exp (cadr v-form)))
        !           356:        (if (null ssimp)
        !           357:           then (push nil g-locs)
        !           358:                (incr g-loccnt)
        !           359:                (let ((g-loc 'r1)
        !           360:                      (g-cc nil))
        !           361:                    (d-exp (caddr v-form)))
        !           362:                (d-move 'unstack 'reg)
        !           363:                (unpush g-locs)
        !           364:                (decr g-loccnt)
        !           365:                (e-move 'r1 '(4 r0))
        !           366:           else (e-move (e-cvt ssimp)  '(4 r0)))
        !           367:        (d-clearreg)))          ; cant tell what we are clobbering
        !           368: 
        !           369: #+for-68k
        !           370: (defun c-rplaca nil
        !           371:    (let ((ssimp (d-simple (caddr v-form)))
        !           372:         (g-ret nil))
        !           373:        (makecomment `(c-rplaca starting :: v-form = ,v-form))
        !           374:        (let ((g-loc (if ssimp then 'areg else 'stack))
        !           375:             (g-cc nil))
        !           376:           (d-exp (cadr v-form)))
        !           377:        (if (null ssimp)
        !           378:           then (push nil g-locs)
        !           379:                (incr g-loccnt)
        !           380:                (let ((g-loc 'd1)
        !           381:                      (g-cc nil))
        !           382:                    (d-exp (caddr v-form)))
        !           383:                (d-move 'unstack 'areg)
        !           384:                (unpush g-locs)
        !           385:                (decr g-loccnt)
        !           386:                (e-move 'd1 '(4 a0))
        !           387:           else (e-move (e-cvt ssimp)  '(4 a0)))
        !           388:        (e-move 'a0 'd0)
        !           389:        (d-clearreg)
        !           390:        (makecomment `(c-rplaca done))))
        !           391: 
        !           392: ; c-rplacd :: compile a "rplacd" expression
        !           393: ;
        !           394: #+for-vax
        !           395: (defun c-rplacd nil
        !           396:   (let ((ssimp (d-simple (caddr v-form)))
        !           397:        (g-ret nil))
        !           398:        (let ((g-loc (if ssimp then 'reg else 'stack))
        !           399:             (g-cc nil))
        !           400:            (d-exp (cadr v-form)))
        !           401:        (if (null ssimp)
        !           402:           then (push nil g-locs)
        !           403:                (incr g-loccnt)
        !           404:                (let ((g-loc 'r1)
        !           405:                      (g-cc nil))
        !           406:                    (d-exp (caddr v-form)))
        !           407:                (d-move 'unstack 'reg)
        !           408:                (unpush g-locs)
        !           409:                (decr g-loccnt)
        !           410:                (e-move 'r1 '(0 r0))
        !           411:           else (e-move (e-cvt ssimp)  '(0 r0)))
        !           412:        (d-clearreg)))
        !           413: 
        !           414: #+for-68k
        !           415: (defun c-rplacd nil
        !           416:    (let ((ssimp (d-simple (caddr v-form)))
        !           417:         (g-ret nil))
        !           418:        (makecomment `(c-rplacd starting :: v-form = ,v-form))
        !           419:        (let ((g-loc (if ssimp then 'areg else 'stack))
        !           420:             (g-cc nil))
        !           421:           (d-exp (cadr v-form)))
        !           422:        (if (null ssimp)
        !           423:           then (push nil g-locs)
        !           424:                (incr g-loccnt)
        !           425:                (let ((g-loc 'd1)
        !           426:                      (g-cc nil))
        !           427:                    (d-exp (caddr v-form)))
        !           428:                (d-move 'unstack 'areg)
        !           429:                (unpush g-locs)
        !           430:                (decr g-loccnt)
        !           431:                (e-move 'd1 '(0 a0))
        !           432:           else (e-move (e-cvt ssimp) '(0 a0)))
        !           433:        (e-move 'a0 'd0)
        !           434:        (d-clearreg)
        !           435:        (makecomment `(d-rplacd done))))
        !           436: 
        !           437: ;--- cc-setq :: compile a "setq" expression
        !           438: ;
        !           439: (defun cc-setq nil
        !           440:   (let (tmp tmp2)
        !           441:        (if (oddp (length (cdr v-form)))
        !           442:           then (comp-err "wrong number of args to setq "
        !           443:                          (or v-form))
        !           444:        elseif (cdddr v-form)           ; if multiple setq's
        !           445:           then (do ((ll (cdr v-form) (cddr ll))
        !           446:                     (g-loc)
        !           447:                     (g-cc nil))
        !           448:                    ((null (cddr ll)) (setq tmp ll))
        !           449:                    (setq g-loc (d-locv (car ll)))
        !           450:                    (d-exp (cadr ll))
        !           451:                    (d-clearuse (car ll)))
        !           452:        else (setq tmp (cdr v-form)))
        !           453: 
        !           454:        ; do final setq
        !           455:        (let ((g-loc (d-locv (car tmp)))
        !           456:             (g-cc (if g-loc then nil else g-cc))
        !           457:             (g-ret nil))
        !           458:            (d-exp (cadr tmp))
        !           459:            (d-clearuse (car tmp)))
        !           460:        (if g-loc
        !           461:           then (d-move (setq tmp2 (d-locv (car tmp))) g-loc)
        !           462:                (if g-cc
        !           463:                    then #+for-68k (d-cmpnil tmp2)
        !           464:                         (d-handlecc)))))
        !           465: 
        !           466: ; cc-typep :: compile a "typep" expression
        !           467: ; 
        !           468: ; this returns the type of the expression, it is always non nil
        !           469: ;
        !           470: #+for-vax
        !           471: (defun cc-typep nil
        !           472:   (let ((argloc (d-simple (cadr v-form)))
        !           473:        (g-ret))
        !           474:        (if (null argloc)
        !           475:           then (let ((g-loc 'reg) g-cc)
        !           476:                    (d-exp (cadr v-form)))
        !           477:                (setq argloc 'reg))
        !           478:        (if g-loc
        !           479:           then (e-write4 'ashl '($ -9) (e-cvt argloc) 'r0)
        !           480:                (e-write3 'cvtbl "_typetable+1[r0]" 'r0)
        !           481:                (e-move "_tynames+4[r0]" 'r0)
        !           482:                (e-move '(0 r0) (e-cvt g-loc)))
        !           483:        (if (car g-cc) then (e-goto (car g-cc)))))
        !           484: 
        !           485: #+for-68k
        !           486: (defun cc-typep nil
        !           487:   (let ((argloc (d-simple (cadr v-form)))
        !           488:        (g-ret))
        !           489:        (if (null argloc) 
        !           490:           then (let ((g-loc 'reg) g-cc)
        !           491:                    (d-exp (cadr v-form)))
        !           492:                (setq argloc 'reg))
        !           493:        (if g-loc
        !           494:           then (e-move (e-cvt argloc) 'd0)
        !           495:                (e-sub '#.nil-reg 'd0)
        !           496:                (e-write3 'moveq '($ 9) 'd1)
        !           497:                (e-write3 'asrl 'd1 'd0)
        !           498:                (e-write3 'lea '"_typetable+1" 'a5)
        !           499:                (e-add 'd0 'a5)
        !           500:                (e-write3 'movb '(0 a5) 'd0)
        !           501:                (e-write2 'extw 'd0)
        !           502:                (e-write2 'extl 'd0)
        !           503:                (e-write3 'asll '($ 2) 'd0)
        !           504:                (e-write3 'lea "_tynames+4" 'a5)
        !           505:                (e-add 'd0 'a5)
        !           506:                (e-move '(0 a5) 'a5)
        !           507:                (e-move '(0 a5) (e-cvt g-loc)))
        !           508:        (if (car g-cc) then (e-goto (car g-cc)))))
        !           509: 
        !           510: ; cm-symeval :: compile a symeval expression.
        !           511: ; the symbol cell in franz lisp is just the cdr.
        !           512: ;
        !           513: (defun cm-symeval nil
        !           514:   `(cdr ,(cadr v-form)))
        !           515: 
        !           516: ; c-*throw :: compile a "*throw" expression
        !           517: ;
        !           518: ; the form of *throw is (*throw 'tag 'val) .
        !           519: ; we calculate and stack the value of tag, then calculate val 
        !           520: ; we call Idothrow to do the actual work, and only return if the
        !           521: ; throw failed.
        !           522: ;
        !           523: (defun c-*throw nil
        !           524:   (let ((arg2loc (d-simple (caddr v-form)))
        !           525:        g-cc
        !           526:        g-ret
        !           527:        arg1loc)
        !           528:        ; put on the C runtime stack value to throw, and
        !           529:        ; tag to throw to.
        !           530:        (if arg2loc
        !           531:           then (if (setq arg1loc (d-simple (cadr v-form)))
        !           532:                    then (C-push (e-cvt arg2loc))
        !           533:                         (C-push (e-cvt arg1loc))
        !           534:                    else (let ((g-loc 'reg))
        !           535:                             (d-exp (cadr v-form))      ; calc tag
        !           536:                             (C-push (e-cvt arg2loc))
        !           537:                             (C-push (e-cvt 'reg))))
        !           538:           else (let ((g-loc 'stack))
        !           539:                    (d-exp (cadr v-form))       ; calc tag to stack
        !           540:                    (push nil g-locs)
        !           541:                    (incr g-loccnt)
        !           542:                    (setq g-loc 'reg)
        !           543:                    (d-exp (caddr v-form))      ; calc value into reg
        !           544:                    (C-push (e-cvt 'reg))
        !           545:                    (C-push (e-cvt 'unstack))
        !           546:                    (unpush g-locs)
        !           547:                    (decr g-loccnt)))
        !           548:        ; now push the type of non local go we are doing, in this case
        !           549:        ; it is a C_THROW
        !           550:        (C-push '($ #.C_THROW))
        !           551:        #+for-vax
        !           552:        (e-write3 'calls '$3 '_Inonlocalgo)
        !           553:        #+for-68k
        !           554:        (e-quick-call '_Inonlocalgo)))
        !           555: 
        !           556: ;--- cm-zerop ::  convert zerop to a quick test
        !           557: ; zerop is only allowed on fixnum and flonum arguments.  In both cases,
        !           558: ; if the value of the first 32 bits is zero, then we have a zero.
        !           559: ; thus we can define it as a macro:
        !           560: #+for-vax
        !           561: (defun cm-zerop nil
        !           562:   (cond ((atom (cadr v-form))
        !           563:         `(and (null (cdr ,(cadr v-form))) (not (bigp ,(cadr v-form)))))
        !           564:        (t (let ((gnsy (gensym)))
        !           565:                `((lambda (,gnsy)
        !           566:                          (and (null (cdr ,gnsy)) 
        !           567:                                (not (bigp ,gnsy))))
        !           568:                  ,(cadr v-form))))))
        !           569: 
        !           570: #+for-68k
        !           571: (defun cm-zerop nil
        !           572:    (cond ((atom (cadr v-form))
        !           573:          `(and (=& 0 ,(cadr v-form))   ;was (cdr ,(cadr v-form))
        !           574:                (not (bigp ,(cadr v-form)))))
        !           575:         (t (let ((gnsy (gensym)))
        !           576:                `((lambda (,gnsy)
        !           577:                      (and (=& 0 ,gnsy)         ;was (cdr ,gnsy)
        !           578:                           (not (bigp ,gnsy))))
        !           579:                  ,(cadr v-form))))))

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