Return to fixnum.l CVS log

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

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

1.1     ! root        1: (include-if (null (get 'chead 'version)) "../chead.l")
        !             2: (Liszt-file fixnum
        !             3:    "$Header: /usr/src/local/franz/liszt/RCS/fixnum.l,v 1.16 88/04/26 11:50:18 sklower Exp $")
        !             4: 
        !             5: ;;; ----       f i x n u m             fixnum compilation
        !             6: ;;;
        !             7: ;;;                            -[Fri Aug 26 14:07:53 1983 by layer]-
        !             8: 
        !             9: ;  There are a few functions in lisp which are only permitted to take
        !            10: ; fixnum operands and produce fixnum results.  The compiler recognizes
        !            11: ; these functions and open codes them.
        !            12: ;
        !            13: 
        !            14: ;--- d-fixnumexp :: compute a fixnum from an expression
        !            15: ;      x - a lisp expression which must return a fixnum
        !            16: ;
        !            17: ; This is an almost equivalent to d-exp, except that
        !            18: ; 1] it will do clever things if the expression can be open coded in a 
        !            19: ;    fixnum way.
        !            20: ; 2] the result must be a fixnum, and is left in r5 unboxed.
        !            21: ;
        !            22: (defun d-fixnumexp (x)
        !            23:   (d-fixnumcode (d-fixexpand x)))
        !            24: 
        !            25: 
        !            26: ;--- c-fixnumop :: compute a fixnum result
        !            27: ;  This is the extry point into this code from d-exp.  The form to evaluate
        !            28: ; is in v-form.  The only way we could get here is if the car of v-form
        !            29: ; is a function which we've stated is a fixnum returning function. 
        !            30: ;
        !            31: (defun c-fixnumop nil
        !            32:   (d-fixnumexp v-form)
        !            33:   (d-fixnumbox))
        !            34: 
        !            35: ;--- d-fixnumbox :: rebox a fixnum in r5
        !            36: ;
        !            37: #+(or for-vax for-tahoe)
        !            38: (defun d-fixnumbox ()
        !            39:    (let (x)
        !            40:        (e-write3 'moval (concat "*$5120[" '#.fixnum-reg "]") 'r0)
        !            41:        (e-sub3 '($ 1024) '#.fixnum-reg 'r1)
        !            42:        (e-write2 'blssu (setq x (d-genlab)))
        !            43:        (e-call-qnewint)
        !            44:        (e-writel x)
        !            45:        (d-clearreg)))
        !            46: 
        !            47: #+for-68k
        !            48: (defun d-fixnumbox ()
        !            49:    (let (x)
        !            50:        (d-regused '#.fixnum-reg)
        !            51:        (e-move '#.fixnum-reg 'd0)
        !            52:        (e-write3 'asll '($ 2) 'd0)
        !            53:        ; add onto the base of the fixnums
        !            54:        (e-add (e-cvt '(fixnum 0)) 'd0)
        !            55:        (e-move '#.fixnum-reg 'd1) 
        !            56:        (e-sub '($ 1024) 'd1)
        !            57:        (e-write2 'jcs (setq x (d-genlab)))     ;branch carry set
        !            58:        (e-call-qnewint)
        !            59:        (e-writel x)
        !            60:        (d-clearreg)))
        !            61: 
        !            62: ;--- d-fixexpand  :: pass over a fixnum expression doing local optimizations
        !            63: ; 
        !            64: ; This code gets the first look at the operands of a fixnum expression.
        !            65: ; It handles the strange cases, like (+) or (/ 3), and it also insures
        !            66: ; that constants are folded (or collapsed as we call it here).
        !            67: ; 
        !            68: ; things to watch out for:
        !            69: ; (+ x y z) we can fold x,y,z , likewise in the case of *
        !            70: ; (- x y z) we can only fold y and z since they are negated but x is not,
        !            71: ;          likewise for /
        !            72: (defun d-fixexpand (x)
        !            73:   (prog nil
        !            74:        (setq x (d-macroexpand x))
        !            75:     loop
        !            76:        (if (and (dtpr x) (symbolp (car x)) (get (car x) 'fixop))
        !            77:            then (if (memq (car x) '(+ *))
        !            78:                     then  (setq x (cons (car x)
        !            79:                                         (d-collapse (cdr x) (car x))))
        !            80:                     else  (setq x
        !            81:                                 (cons (car x)
        !            82:                                       (cons (cadr x)
        !            83:                                             (d-collapse (cddr x) (car x))))))
        !            84:                 (if (null (cdr x))
        !            85:                     then  ; (- or +) => 0 (* or /) => 1
        !            86:                         (setq x
        !            87:                               (cdr (assq (car x)
        !            88:                                          '((+ . 0) (- . 0)
        !            89:                                            (* . 1) (/ . 1)))))
        !            90:                         (go loop)
        !            91:                  elseif (null (cddr x)) then
        !            92:                           ; (+ n) => n, (- n) => (- 0 n), (* n) => n,
        !            93:                           ; (/ n) => (/ 1 n)
        !            94:                          (setq x
        !            95:                                (if (memq (car x) '(* +))
        !            96:                                    then (cadr x)
        !            97:                                 elseif (eq (car x) '-)
        !            98:                                    then `(- 0 ,(cadr x))
        !            99:                                 elseif (eq (car x) '/)
        !           100:                                    then `(/ 1 ,(cadr x))
        !           101:                                    else (comp-err
        !           102:                                             "Internal fixexpand error ")))
        !           103:                          (go loop)))
        !           104:        (return x)))
        !           105: 
        !           106: ;--- d-toplevmacroexpand :: expand top level form if macro
        !           107: ; a singe level of macro expansion is done.  this is a nice general
        !           108: ; routine and should be used by d-exp.
        !           109: ;**** out of date **** will be removed soon
        !           110: (defun d-toplevmacroexpand (x)
        !           111:   (let ((fnbnd (and (dtpr x) (symbolp (car x)) (getd (car x)))))
        !           112:        (if (and fnbnd (or (and (bcdp fnbnd) (eq (getdisc fnbnd) 'macro))
        !           113:                          (and (dtpr fnbnd) (eq (car fnbnd) 'macro))))
        !           114:           then (d-toplevmacroexpand (apply fnbnd x))
        !           115:           else x)))
        !           116: 
        !           117: 
        !           118: ;--- d-collapse :: collapse (fold) constants
        !           119: ; 
        !           120: ; this is used to reduce the number of operations. since we know that
        !           121: ; fixnum operations are commutative.
        !           122: ;
        !           123: (defun d-collapse (form op)
        !           124:   (let (const res conlist)
        !           125:        ; generate list of constants (conlist) and non constants (res)
        !           126:        (do ((xx form (cdr xx)))
        !           127:           ((null xx))
        !           128:           (if (numberp (car xx))
        !           129:               then (if (fixp (car xx))
        !           130:                        then (setq conlist (cons (car xx) conlist))
        !           131:                        else (comp-err "Illegal operand in fixnum op " 
        !           132:                                       (car xx)))
        !           133:               else (setq res (cons (car xx) res))))
        !           134: 
        !           135:        ; if no constants found thats ok, but if we found some,
        !           136:        ; then collapse and return the form with the collapsed constant
        !           137:        ; at the end.
        !           138: 
        !           139:        (if (null conlist)
        !           140:           then form    ; no change
        !           141:           else (setq res (nreverse 
        !           142:                 (cons (apply (cond ((or (eq op '/) (eq op '*)) 'times)
        !           143:                                    (t 'plus)) 
        !           144:                              (cons (cond ((or (eq op '/) (eq op '*)) 1)
        !           145:                                          (t 0))
        !           146:                                    conlist))
        !           147:                       res))))))
        !           148: 
        !           149: 
        !           150: ;---- d-fixnumcode :: emit code for prescanned fixnum expression
        !           151: ;      expr -  a expression which should return an unboxed fixnum value 
        !           152: ;              in r5.
        !           153: ;  This function checks if the expression is indeed a guaranteed fixnum 
        !           154: ; arithmetic expression, and if so , generates code for the operation.
        !           155: ; If the expression is not a fixnum operation, then a normal evaluation
        !           156: ; of the cdr of the expression is done, which will grab the fixnum value
        !           157: ; and put it in r5.
        !           158: ;
        !           159: #+(or for-vax for-tahoe)
        !           160: (defun d-fixnumcode (expr)
        !           161:   (let ((operator (and (dtpr expr) 
        !           162:                       (symbolp (car expr)) 
        !           163:                       (get (car expr) 'fixop)))
        !           164:        (g-ret nil)
        !           165:        tmp)
        !           166:        ; the existance of a fixop property on a function says that it is a
        !           167:        ; special fixnum only operation.
        !           168:        (if (null operator) 
        !           169:           then (let ((g-loc '#.fixnum-reg) g-cc) ; non fixnum op, do normal
        !           170:                     (d-exp `(cdr ,expr)))      ; eval to get unboxed number
        !           171:           else (do ((xx (cdr expr) (cdr xx))   ; fixnum op, scan all args
        !           172:                     (lop) (rop) (res) (opnd))
        !           173:                    ((null xx))
        !           174:                    (setq opnd (car xx))
        !           175:                    (if (fixp opnd) 
        !           176:                        then (setq rop `(immed ,opnd))
        !           177:                     elseif (and (symbolp opnd) 
        !           178:                                 (setq rop (d-simple `(cdr ,opnd))))
        !           179:                            thenret
        !           180:                        else (if (and lop (not (eq lop '#.unCstack)))
        !           181:                                 then (C-push (e-cvt lop))
        !           182:                                 (setq lop '#.unCstack))
        !           183:                             (d-fixnumcode (d-fixexpand opnd))
        !           184:                             (setq rop 'r5))
        !           185:                    (if (null lop) 
        !           186:                        then (if (cdr xx) 
        !           187:                                 then (setq lop rop)
        !           188:                                 else (e-move (e-cvt rop) 'r5))
        !           189:                        else (if (cdr xx) 
        !           190:                                 then (setq res '#.Cstack)
        !           191:                                 else (setq res 'r5))
        !           192:                             (if (setq tmp (d-shiftcheck operator rop))
        !           193:                                 then (e-write4 #+for-vax 'ashl 
        !           194:                                                #+for-tahoe 'shal
        !           195:                                                (e-cvt (list 'immed tmp))
        !           196:                                                (e-cvt lop)
        !           197:                                                (e-cvt res))
        !           198:                                 else (e-write4 operator (e-cvt rop) 
        !           199:                                                (e-cvt lop) 
        !           200:                                                (e-cvt res)))
        !           201:                             (if (cdr xx) 
        !           202:                                 then (setq lop '#.unCstack)
        !           203:                                 else (setq lop "r5")))))))
        !           204: 
        !           205: #+for-68k
        !           206: (defun d-fixnumcode (expr)
        !           207:    (let ((operator (and (dtpr expr)
        !           208:                        (symbolp (car expr))
        !           209:                        (get (car expr) 'fixop)))
        !           210:         (g-ret nil)
        !           211:         tmp)
        !           212:        ; the existance of a fixop property on a function says that it is a
        !           213:        ; special fixnum only operation.
        !           214:        (makecomment `(d-fixnumcode ,expr))
        !           215:        (if (null operator) 
        !           216:           then (let ((g-loc '#.fixnum-reg) g-cc) ; non fixnum op, do normal
        !           217:                    (d-exp `(cdr ,expr)))         ; eval to get unboxed number
        !           218:                (d-regused '#.fixnum-reg)
        !           219:           else (do ((xx (cdr expr) (cdr xx))     ; fixnum op, scan all args
        !           220:                     (lop) (rop) (res) (opnd))
        !           221:                    ((null xx))
        !           222:                    (setq opnd (car xx))
        !           223:                    (if (fixp opnd) 
        !           224:                        then (setq rop `(immed ,opnd))
        !           225:                     elseif (and (symbolp opnd)
        !           226:                                 (setq rop (d-simple `(cdr ,opnd))))
        !           227:                        thenret
        !           228:                        else (if (and lop (not (eq lop '#.unCstack)))
        !           229:                                 then (C-push (e-cvt lop))
        !           230:                                      (setq lop '#.unCstack))
        !           231:                             (d-fixnumcode (d-fixexpand opnd))
        !           232:                             (setq rop '#.fixnum-reg))
        !           233:                    (if (null lop) 
        !           234:                        then (if (cdr xx) 
        !           235:                                 then (setq lop rop)
        !           236:                                 else (e-move
        !           237:                                                (e-cvt rop)
        !           238:                                                '#.fixnum-reg))
        !           239:                        else (if (cdr xx) 
        !           240:                                 then (setq res '#.Cstack)
        !           241:                                 else (setq res '#.fixnum-reg))
        !           242:                             (if (setq tmp (d-shiftcheck operator rop))
        !           243:                                 then (d-asll tmp (e-cvt lop) (e-cvt res))
        !           244:                                 else (e-move (e-cvt lop) 'd0)
        !           245:                                      (e-write3 operator (e-cvt rop) 'd0)
        !           246:                                      (e-move 'd0 (e-cvt res)))
        !           247:                             (if (cdr xx) 
        !           248:                                 then (setq lop '#.unCstack)
        !           249:                                 else (setq lop '#.fixnum-reg)))))
        !           250:        (makecomment '(d-fixnumcode done))))
        !           251: 
        !           252: ;--- d-shiftcheck      :: check if we can shift instead of multiply
        !           253: ; return t if the operator is a multiply and the operand is an
        !           254: ; immediate whose value is a power of two.
        !           255: (defun d-shiftcheck (operator operand)
        !           256:    (and (eq operator #+(or for-vax for-tahoe) 'lmul
        !           257:                     #+for-68k 'mull3)
        !           258:        (dtpr operand)
        !           259:        (eq (car operand) 'immed)
        !           260:        (cdr (assoc (cadr operand) arithequiv))))
        !           261: 
        !           262: ; this table is incomplete 
        !           263: ;
        !           264: (setq arithequiv '((1 . 0) (2 . 1) (4 . 2) (8 . 3) (16 . 4) (32 . 5)
        !           265:                   (64 . 6) (128 . 7) (256 . 8) (512 . 9) (1024 . 10)
        !           266:                   (2048 . 11) (4096 . 12) (8192 . 13) (16384 . 14)
        !           267:                   (32768 . 15) (65536 . 16) (131072 . 17)))
        !           268: 
        !           269: 
        !           270: ;--- cc-oneplus  :: compile 1+ form                    = cc-oneplus =
        !           271: ;  1+ increments a fixnum only. We generate code to check if the number
        !           272: ; to be incremented is a small fixnum less than or equal to 1022.  This
        !           273: ; check is done by checking the address of the fixnum's box.  If the
        !           274: ; number is in that range, we just increment the box pointer by 4.
        !           275: ; otherwise we call we call _qoneplus which does the add and calls
        !           276: ; _qnewint
        !           277: ;
        !           278: #+(or for-vax for-tahoe)
        !           279: (defun cc-oneplus nil
        !           280:   (if (null g-loc)
        !           281:       then (if (car g-cc) then (e-goto (car g-cc)))
        !           282:       else (let ((argloc (d-simple (cadr v-form)))
        !           283:                 (lab1 (d-genlab))
        !           284:                 (lab2 (d-genlab)))
        !           285:                (if (null argloc) 
        !           286:                    then (let ((g-loc 'r0) g-cc g-ret)
        !           287:                              (d-exp (cadr v-form)))
        !           288:                         (setq argloc 'reg))
        !           289:                (e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1022))))
        !           290:                (e-write2 'jleq lab1)
        !           291:                (if (not (eq argloc 'r0)) then (d-move argloc 'reg))
        !           292:                (e-quick-call '_qoneplus)
        !           293:                (if (and g-loc (not (eq g-loc 'reg)))
        !           294:                    then (d-move 'reg g-loc))
        !           295:                (if (car g-cc)
        !           296:                    then (e-goto (car g-cc))
        !           297:                    else (e-goto lab2))
        !           298:                (e-label lab1)
        !           299:                (e-add3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
        !           300:                (if (car g-cc) then (e-goto (car g-cc)))
        !           301:                (e-label lab2))))
        !           302: 
        !           303: #+for-68k
        !           304: (defun cc-oneplus nil
        !           305:    (if (null g-loc)
        !           306:        then (if (car g-cc) then (e-goto (car g-cc)))
        !           307:        else (let ((argloc (d-simple (cadr v-form)))
        !           308:                  (lab1 (d-genlab))
        !           309:                  (lab2 (d-genlab)))
        !           310:                (if (null argloc) 
        !           311:                    then (let ((g-loc 'areg) g-cc g-ret)
        !           312:                             (d-exp (cadr v-form)))
        !           313:                         (setq argloc 'areg))
        !           314:                ; ($ (+ Fixzero (* 4 1022))
        !           315:                (d-cmp argloc '(fixnum 1022))
        !           316:                (e-write2 'jle lab1)
        !           317:                (if (not (eq argloc 'areg)) then (d-move argloc 'areg))
        !           318:                (e-quick-call '_qoneplus)
        !           319:                (if (and g-loc (not (eq g-loc 'reg)))
        !           320:                    then (d-move 'reg g-loc))
        !           321:                (if (car g-cc)
        !           322:                    then (e-goto (car g-cc))
        !           323:                    else (e-goto lab2))
        !           324:                (e-label lab1)
        !           325:                (if (not (eq argloc 'reg))
        !           326:                    then (d-move argloc 'reg))
        !           327:                (e-write3 'addql "#4" 'd0)
        !           328:                (if (and g-loc (not (eq g-loc 'reg)))
        !           329:                    then (d-move 'reg g-loc))
        !           330:                (if (car g-cc) then (e-goto (car g-cc)))
        !           331:                (e-label lab2))))
        !           332:                        
        !           333: 
        !           334: 
        !           335: ;--- cc-oneminus :: compile the 1- form
        !           336: ; just like 1+ we check to see if we are decrementing an small fixnum.
        !           337: ; and if we are we just decrement the pointer to the fixnum and save
        !           338: ; a call to qinewint.  The valid range of fixnums we can decrement are
        !           339: ; 1023 to -1023.  This requires two range checks (as opposed to one for 1+).
        !           340: ;
        !           341: #+(or for-vax for-tahoe)
        !           342: (defun cc-oneminus nil
        !           343:   (if (null g-loc)
        !           344:       then (if (car g-cc) then (e-goto (car g-cc)))
        !           345:       else (let ((argloc (d-simple (cadr v-form)))
        !           346:                 (lab1 (d-genlab))
        !           347:                 (lab2 (d-genlab))
        !           348:                 (lab3 (d-genlab)))
        !           349:                (if (null argloc) 
        !           350:                    then (let ((g-loc 'r0) g-cc)
        !           351:                              (d-exp (cadr v-form)))
        !           352:                         (setq argloc 'reg))
        !           353:                (e-cmp (e-cvt argloc) '($ #.(- 5120 (* 4 1024))))
        !           354:                (e-write2 'jleq lab1)   ; not within range
        !           355:                (e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1023))))
        !           356:                (e-write2 'jleq lab2)   ; within range
        !           357:                ; not within range, must do it the hard way.
        !           358:                (e-label lab1)
        !           359:                (if (not (eq argloc 'r0)) then (d-move argloc 'reg))
        !           360:                (e-quick-call '_qoneminus)
        !           361:                (if (and g-loc (not (eq g-loc 'reg)))
        !           362:                    then (d-move 'reg g-loc))
        !           363:                (if (car g-cc)
        !           364:                    then (e-goto (car g-cc))
        !           365:                    else (e-goto lab3))
        !           366:                (e-label lab2)
        !           367:                ; we are within range, just decrement the pointer by the
        !           368:                ; size of a word (4 bytes).
        !           369:                (e-sub3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
        !           370:                (if (car g-cc) then (e-goto (car g-cc)))
        !           371:                (e-label lab3))))
        !           372: 
        !           373: #+for-68k
        !           374: (defun cc-oneminus nil
        !           375:   (if (null g-loc)
        !           376:       then (if (car g-cc) then (e-goto (car g-cc)))
        !           377:       else (let ((argloc (d-simple (cadr v-form)))
        !           378:                 (lab1 (d-genlab))
        !           379:                 (lab2 (d-genlab))
        !           380:                 (lab3 (d-genlab)))
        !           381:                (if (null argloc) 
        !           382:                    then (let ((g-loc 'areg) g-cc)
        !           383:                              (d-exp (cadr v-form)))
        !           384:                         (setq argloc 'areg))
        !           385:                ; ($ (- Fixzero (* 4 1024)))
        !           386:                (d-cmp argloc '(fixnum -1024))
        !           387:                (e-write2 'jle lab1)    ; not within range
        !           388:                (d-cmp argloc '(fixnum 1023))
        !           389:                (e-write2 'jle lab2)    ; within range
        !           390:                ; not within range, must do it the hard way.
        !           391:                (e-label lab1)
        !           392:                (if (not (eq argloc 'areg)) then (d-move argloc 'areg))
        !           393:                (e-quick-call '_qoneminus)
        !           394:                (if (and g-loc (not (eq g-loc 'reg)))
        !           395:                    then (d-move 'reg g-loc))
        !           396:                (if (car g-cc)
        !           397:                    then (e-goto (car g-cc))
        !           398:                    else (e-goto lab3))
        !           399:                (e-label lab2)
        !           400:                ; we are within range, just decrement the pointer by the
        !           401:                ; size of a word (4 bytes).
        !           402:                (if (not (eq argloc 'reg))
        !           403:                    then (d-move argloc 'reg))
        !           404:                (e-sub '($ 4) 'd0)
        !           405:                (if (and g-loc (not (eq g-loc 'reg)))
        !           406:                    then (d-move 'reg g-loc))
        !           407:                (if (car g-cc) then (e-goto (car g-cc)))
        !           408:                (e-label lab3))))
        !           409: 
        !           410: ;--- cm-<  :: compile a < expression
        !           411: ; 
        !           412: ; the operands to this form can either be fixnum or flonums but they
        !           413: ; must be of the same type.
        !           414: ;
        !           415: ; We can compile the form just like an eq form since all we want is
        !           416: ; a compare and a jump.  The comparisons are inverted since that is
        !           417: ; the way eq expects it.
        !           418: 
        !           419: (defun cm-< nil
        !           420:    (if (not (= 2 (length (cdr v-form))))
        !           421:       then (comp-err "incorrect number of arguments to < " v-form))
        !           422:    ; only can do fixnum stuff if we know that one of the args is
        !           423:    ; a fixnum.
        !           424:    ;
        !           425:    (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
        !           426:       then `(<& ,(cadr v-form) ,(caddr v-form))
        !           427:       else `(lessp ,(cadr v-form) ,(caddr v-form))))
        !           428: 
        !           429: ;--- c-<& :: fixnum <
        !           430: ;
        !           431: ; We can compile the form just like an eq form since all we want is
        !           432: ; a compare and a jump.  The comparisons are inverted since that is
        !           433: ; the way eq expects it.
        !           434: 
        !           435: (defun cc-<& nil
        !           436:    (let ((g-trueop  #+(or for-vax for-tahoe) 'jgeq #+for-68k 'jpl)
        !           437:         (g-falseop #+(or for-vax for-tahoe) 'jlss #+for-68k 'jmi)
        !           438:         (v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
        !           439:       (cc-eq)))
        !           440: 
        !           441: ;--- cm->  :: compile a > expression
        !           442: ;
        !           443: ; the operands to this form can either be fixnum or flonums but they
        !           444: ; must be of the same type.  
        !           445: ; We can compile the form just like an eq form since all we want is
        !           446: ; a compare and a jump.  The comparisons are inverted since that is
        !           447: ; the way eq expects it.
        !           448: (defun cm-> nil
        !           449:    (if (not (= 2 (length (cdr v-form))))
        !           450:       then (comp-err "incorrect number of arguments to > " v-form))
        !           451:    ; only can do fixnum stuff if we know that one of the args is
        !           452:    ; a fixnum.
        !           453:    ;
        !           454:    (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
        !           455:       then `(>& ,(cadr v-form) ,(caddr v-form))
        !           456:       else `(greaterp ,(cadr v-form) ,(caddr v-form))))
        !           457: 
        !           458: ;--- cc->& :: compile a fixnum > function
        !           459: ;
        !           460: ; We can compile the form just like an eq form since all we want is
        !           461: ; a compare and a jump.  The comparisons are inverted since that is
        !           462: ; the way eq expects it.
        !           463: (defun cc->& nil
        !           464:    (let ((g-trueop  #+(or for-vax for-tahoe) 'jleq #+for-68k 'jle)
        !           465:         (g-falseop #+(or for-vax for-tahoe) 'jgtr #+for-68k 'jgt)
        !           466:         (v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
        !           467:       (cc-eq)))
        !           468: 
        !           469: ;--- cm-=  : compile an = expression
        !           470: ;  The = function is a strange one.  It can compare two fixnums or two
        !           471: ; flonums which is fine on a pdp-10 where they are the same size, but
        !           472: ; is a real pain on a vax where they are different sizes.
        !           473: ; We thus can see if one of the arguments is a fixnum and assume that
        !           474: ; the other one is and then  call =&, the fixnum equal code.
        !           475: ;
        !           476: (defun cm-= nil
        !           477:    (if (not (= 2 (length (cdr v-form))))
        !           478:       then (comp-err "incorrect number of arguments to = : " v-form))
        !           479:    (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
        !           480:       then `(=& ,(cadr v-form) ,(caddr v-form))
        !           481:       else `(equal ,(cadr v-form) ,(caddr v-form))))
        !           482: 
        !           483: ;--- cm-=&
        !           484: ;
        !           485: ; if the number is within the small fixnum range, we can just
        !           486: ; do pointer comparisons.
        !           487: ;
        !           488: (defun cm-=& nil
        !           489:    (if (or (and (fixp (cadr v-form))
        !           490:                (< (cadr v-form) 1024)
        !           491:                (> (cadr v-form) -1025))
        !           492:           (and (fixp (caddr v-form))
        !           493:                (< (caddr v-form) 1024)
        !           494:                (> (caddr v-form) -1025)))
        !           495:       then `(eq ,(cadr v-form) ,(caddr v-form))
        !           496:       else `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
        !           497: 
        !           498: ; this should be converted
        !           499: #+(or for-vax for-tahoe)
        !           500: (defun c-\\ nil
        !           501:    (d-fixop 'ediv  'remainder))
        !           502: 
        !           503: #+(or for-vax for-tahoe)
        !           504: (defun d-fixop (opcode lispopcode)
        !           505:    (prog (op1 op2 rop1 rop2 simpleop1)
        !           506:        (if (not (eq 3 (length v-form))) ; only handle two ops for now
        !           507:           then (d-callbig lispopcode (cdr v-form) nil)
        !           508:           else (setq op1 (cadr v-form)
        !           509:                      op2 (caddr v-form))
        !           510:                (if (fixp op1)
        !           511:                    then (setq rop1 `($ ,op1)  ; simple int
        !           512:                               simpleop1 t)         
        !           513:                    else (if (setq rop1 (d-simple `(cdr ,op1)))
        !           514:                             then (setq rop1 (e-cvt rop1))
        !           515:                             else (let ((g-loc 'reg) g-cc g-ret)
        !           516:                                      (d-exp op1))
        !           517:                                  (setq rop1 '(0 r0))))
        !           518:                (if (fixp op2)
        !           519:                    then (setq rop2 `($ ,op2))
        !           520:                    else (if (setq rop2 (d-simple `(cdr ,op2)))
        !           521:                             then (setq rop2 (e-cvt rop2))
        !           522:                             else (C-push rop1)
        !           523:                                  (setq rop1 '#.unCstack)
        !           524:                                  (let ((g-loc 'reg)
        !           525:                                        g-cc g-ret)
        !           526:                                      (d-exp op2))
        !           527:                                  (setq rop2 '(0 r0))))
        !           528:                (if (eq opcode 'ediv)
        !           529:                    then (if (not simpleop1)
        !           530:                             then #+for-vax (progn (e-move rop1 'r2) ;need quad
        !           531:                                                (e-write4 'ashq '$-32 'r1 'r1))
        !           532:                                  #+for-tahoe (let ((x (d-genlab)))
        !           533:                                                (e-write2 'clrl 'r2)
        !           534:                                                (e-move rop1 'r3)
        !           535:                                                (e-write2 'jgeq x)
        !           536:                                                (e-write3 'mnegl '($ 1) 'r2)
        !           537:                                                (e-writel x))
        !           538:                                  (setq rop1 #+for-vax 'r1 #+for-tahoe 'r2))
        !           539:                                                                ; word div.
        !           540:                         (e-write5 'ediv rop2 rop1 'r0 'r5)
        !           541:                    else (e-write4 opcode rop2 rop1 'r5))
        !           542:                (d-fixnumbox)
        !           543:                (d-clearreg))))

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