Return to fixnum.l CVS log

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

Annotation of 42BSD/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: fixnum.l,v 1.14 83/08/28 17:13:38 layer 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: #+for-vax
        !            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: #+for-vax
        !           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 'ashl 
        !           194:                                                (e-cvt (list 'immed tmp))
        !           195:                                                (e-cvt lop)
        !           196:                                                (e-cvt res))
        !           197:                                 else (e-write4 operator (e-cvt rop) 
        !           198:                                                (e-cvt lop) 
        !           199:                                                (e-cvt res)))
        !           200:                             (if (cdr xx) 
        !           201:                                 then (setq lop '#.unCstack)
        !           202:                                 else (setq lop "r5")))))))
        !           203: 
        !           204: #+for-68k
        !           205: (defun d-fixnumcode (expr)
        !           206:    (let ((operator (and (dtpr expr)
        !           207:                        (symbolp (car expr))
        !           208:                        (get (car expr) 'fixop)))
        !           209:         (g-ret nil)
        !           210:         tmp)
        !           211:        ; the existance of a fixop property on a function says that it is a
        !           212:        ; special fixnum only operation.
        !           213:        (makecomment `(d-fixnumcode ,expr))
        !           214:        (if (null operator) 
        !           215:           then (let ((g-loc '#.fixnum-reg) g-cc) ; non fixnum op, do normal
        !           216:                    (d-exp `(cdr ,expr)))         ; eval to get unboxed number
        !           217:                (d-regused '#.fixnum-reg)
        !           218:           else (do ((xx (cdr expr) (cdr xx))     ; fixnum op, scan all args
        !           219:                     (lop) (rop) (res) (opnd))
        !           220:                    ((null xx))
        !           221:                    (setq opnd (car xx))
        !           222:                    (if (fixp opnd) 
        !           223:                        then (setq rop `(immed ,opnd))
        !           224:                     elseif (and (symbolp opnd)
        !           225:                                 (setq rop (d-simple `(cdr ,opnd))))
        !           226:                        thenret
        !           227:                        else (if (and lop (not (eq lop '#.unCstack)))
        !           228:                                 then (C-push (e-cvt lop))
        !           229:                                      (setq lop '#.unCstack))
        !           230:                             (d-fixnumcode (d-fixexpand opnd))
        !           231:                             (setq rop '#.fixnum-reg))
        !           232:                    (if (null lop) 
        !           233:                        then (if (cdr xx) 
        !           234:                                 then (setq lop rop)
        !           235:                                 else (e-move
        !           236:                                                (e-cvt rop)
        !           237:                                                '#.fixnum-reg))
        !           238:                        else (if (cdr xx) 
        !           239:                                 then (setq res '#.Cstack)
        !           240:                                 else (setq res '#.fixnum-reg))
        !           241:                             (if (setq tmp (d-shiftcheck operator rop))
        !           242:                                 then (d-asll tmp (e-cvt lop) (e-cvt res))
        !           243:                                 else (e-move (e-cvt lop) 'd0)
        !           244:                                      (e-write3 operator (e-cvt rop) 'd0)
        !           245:                                      (e-move 'd0 (e-cvt res)))
        !           246:                             (if (cdr xx) 
        !           247:                                 then (setq lop '#.unCstack)
        !           248:                                 else (setq lop '#.fixnum-reg)))))
        !           249:        (makecomment '(d-fixnumcode done))))
        !           250: 
        !           251: ;--- d-shiftcheck      :: check if we can shift instead of multiply
        !           252: ; return t if the operator is a multiply and the operand is an
        !           253: ; immediate whose value is a power of two.
        !           254: (defun d-shiftcheck (operator operand)
        !           255:    (and (eq operator #+for-vax 'lmul
        !           256:                     #+for-68k 'mull3)
        !           257:        (dtpr operand)
        !           258:        (eq (car operand) 'immed)
        !           259:        (cdr (assoc (cadr operand) arithequiv))))
        !           260: 
        !           261: ; this table is incomplete 
        !           262: ;
        !           263: (setq arithequiv '((1 . 0) (2 . 1) (4 . 2) (8 . 3) (16 . 4) (32 . 5)
        !           264:                   (64 . 6) (128 . 7) (256 . 8) (512 . 9) (1024 . 10)
        !           265:                   (2048 . 11) (4096 . 12) (8192 . 13) (16384 . 14)
        !           266:                   (32768 . 15) (65536 . 16) (131072 . 17)))
        !           267: 
        !           268: 
        !           269: ;--- cc-oneplus  :: compile 1+ form                    = cc-oneplus =
        !           270: ;  1+ increments a fixnum only. We generate code to check if the number
        !           271: ; to be incremented is a small fixnum less than or equal to 1022.  This
        !           272: ; check is done by checking the address of the fixnum's box.  If the
        !           273: ; number is in that range, we just increment the box pointer by 4.
        !           274: ; otherwise we call we call _qoneplus which does the add and calls
        !           275: ; _qnewint
        !           276: ;
        !           277: #+for-vax
        !           278: (defun cc-oneplus nil
        !           279:   (if (null g-loc)
        !           280:       then (if (car g-cc) then (e-goto (car g-cc)))
        !           281:       else (let ((argloc (d-simple (cadr v-form)))
        !           282:                 (lab1 (d-genlab))
        !           283:                 (lab2 (d-genlab)))
        !           284:                (if (null argloc) 
        !           285:                    then (let ((g-loc 'r0) g-cc g-ret)
        !           286:                              (d-exp (cadr v-form)))
        !           287:                         (setq argloc 'reg))
        !           288:                (e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1022))))
        !           289:                (e-write2 'jleq lab1)
        !           290:                (if (not (eq argloc 'r0)) then (d-move argloc 'reg))
        !           291:                (e-quick-call '_qoneplus)
        !           292:                (if (and g-loc (not (eq g-loc 'reg)))
        !           293:                    then (d-move 'reg g-loc))
        !           294:                (if (car g-cc)
        !           295:                    then (e-goto (car g-cc))
        !           296:                    else (e-goto lab2))
        !           297:                (e-label lab1)
        !           298:                (e-add3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
        !           299:                (if (car g-cc) then (e-goto (car g-cc)))
        !           300:                (e-label lab2))))
        !           301: 
        !           302: #+for-68k
        !           303: (defun cc-oneplus nil
        !           304:    (if (null g-loc)
        !           305:        then (if (car g-cc) then (e-goto (car g-cc)))
        !           306:        else (let ((argloc (d-simple (cadr v-form)))
        !           307:                  (lab1 (d-genlab))
        !           308:                  (lab2 (d-genlab)))
        !           309:                (if (null argloc) 
        !           310:                    then (let ((g-loc 'areg) g-cc g-ret)
        !           311:                             (d-exp (cadr v-form)))
        !           312:                         (setq argloc 'areg))
        !           313:                ; ($ (+ Fixzero (* 4 1022))
        !           314:                (d-cmp argloc '(fixnum 1022))
        !           315:                (e-write2 'jle lab1)
        !           316:                (if (not (eq argloc 'areg)) then (d-move argloc 'areg))
        !           317:                (e-quick-call '_qoneplus)
        !           318:                (if (and g-loc (not (eq g-loc 'reg)))
        !           319:                    then (d-move 'reg g-loc))
        !           320:                (if (car g-cc)
        !           321:                    then (e-goto (car g-cc))
        !           322:                    else (e-goto lab2))
        !           323:                (e-label lab1)
        !           324:                (if (not (eq argloc 'reg))
        !           325:                    then (d-move argloc 'reg))
        !           326:                (e-write3 'addql "#4" 'd0)
        !           327:                (if (and g-loc (not (eq g-loc 'reg)))
        !           328:                    then (d-move 'reg g-loc))
        !           329:                (if (car g-cc) then (e-goto (car g-cc)))
        !           330:                (e-label lab2))))
        !           331:                        
        !           332: 
        !           333: 
        !           334: ;--- cc-oneminus :: compile the 1- form
        !           335: ; just like 1+ we check to see if we are decrementing an small fixnum.
        !           336: ; and if we are we just decrement the pointer to the fixnum and save
        !           337: ; a call to qinewint.  The valid range of fixnums we can decrement are
        !           338: ; 1023 to -1023.  This requires two range checks (as opposed to one for 1+).
        !           339: ;
        !           340: #+for-vax
        !           341: (defun cc-oneminus nil
        !           342:   (if (null g-loc)
        !           343:       then (if (car g-cc) then (e-goto (car g-cc)))
        !           344:       else (let ((argloc (d-simple (cadr v-form)))
        !           345:                 (lab1 (d-genlab))
        !           346:                 (lab2 (d-genlab))
        !           347:                 (lab3 (d-genlab)))
        !           348:                (if (null argloc) 
        !           349:                    then (let ((g-loc 'r0) g-cc)
        !           350:                              (d-exp (cadr v-form)))
        !           351:                         (setq argloc 'reg))
        !           352:                (e-cmp (e-cvt argloc) '($ #.(- 5120 (* 4 1024))))
        !           353:                (e-write2 'jleq lab1)   ; not within range
        !           354:                (e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1023))))
        !           355:                (e-write2 'jleq lab2)   ; within range
        !           356:                ; not within range, must do it the hard way.
        !           357:                (e-label lab1)
        !           358:                (if (not (eq argloc 'r0)) then (d-move argloc 'reg))
        !           359:                (e-quick-call '_qoneminus)
        !           360:                (if (and g-loc (not (eq g-loc 'reg)))
        !           361:                    then (d-move 'reg g-loc))
        !           362:                (if (car g-cc)
        !           363:                    then (e-goto (car g-cc))
        !           364:                    else (e-goto lab3))
        !           365:                (e-label lab2)
        !           366:                ; we are within range, just decrement the pointer by the
        !           367:                ; size of a word (4 bytes).
        !           368:                (e-sub3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
        !           369:                (if (car g-cc) then (e-goto (car g-cc)))
        !           370:                (e-label lab3))))
        !           371: 
        !           372: #+for-68k
        !           373: (defun cc-oneminus nil
        !           374:   (if (null g-loc)
        !           375:       then (if (car g-cc) then (e-goto (car g-cc)))
        !           376:       else (let ((argloc (d-simple (cadr v-form)))
        !           377:                 (lab1 (d-genlab))
        !           378:                 (lab2 (d-genlab))
        !           379:                 (lab3 (d-genlab)))
        !           380:                (if (null argloc) 
        !           381:                    then (let ((g-loc 'areg) g-cc)
        !           382:                              (d-exp (cadr v-form)))
        !           383:                         (setq argloc 'areg))
        !           384:                ; ($ (- Fixzero (* 4 1024)))
        !           385:                (d-cmp argloc '(fixnum -1024))
        !           386:                (e-write2 'jle lab1)    ; not within range
        !           387:                (d-cmp argloc '(fixnum 1023))
        !           388:                (e-write2 'jle lab2)    ; within range
        !           389:                ; not within range, must do it the hard way.
        !           390:                (e-label lab1)
        !           391:                (if (not (eq argloc 'areg)) then (d-move argloc 'areg))
        !           392:                (e-quick-call '_qoneminus)
        !           393:                (if (and g-loc (not (eq g-loc 'reg)))
        !           394:                    then (d-move 'reg g-loc))
        !           395:                (if (car g-cc)
        !           396:                    then (e-goto (car g-cc))
        !           397:                    else (e-goto lab3))
        !           398:                (e-label lab2)
        !           399:                ; we are within range, just decrement the pointer by the
        !           400:                ; size of a word (4 bytes).
        !           401:                (if (not (eq argloc 'reg))
        !           402:                    then (d-move argloc 'reg))
        !           403:                (e-sub '($ 4) 'd0)
        !           404:                (if (and g-loc (not (eq g-loc 'reg)))
        !           405:                    then (d-move 'reg g-loc))
        !           406:                (if (car g-cc) then (e-goto (car g-cc)))
        !           407:                (e-label lab3))))
        !           408: 
        !           409: ;--- cm-<  :: compile a < expression
        !           410: ; 
        !           411: ; the operands to this form can either be fixnum or flonums but they
        !           412: ; must be of the same type.
        !           413: ;
        !           414: ; We can compile the form just like an eq form since all we want is
        !           415: ; a compare and a jump.  The comparisons are inverted since that is
        !           416: ; the way eq expects it.
        !           417: 
        !           418: (defun cm-< nil
        !           419:    (if (not (= 2 (length (cdr v-form))))
        !           420:       then (comp-err "incorrect number of arguments to < " v-form))
        !           421:    ; only can do fixnum stuff if we know that one of the args is
        !           422:    ; a fixnum.
        !           423:    ;
        !           424:    (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
        !           425:       then `(<& ,(cadr v-form) ,(caddr v-form))
        !           426:       else `(lessp ,(cadr v-form) ,(caddr v-form))))
        !           427: 
        !           428: ;--- c-<& :: fixnum <
        !           429: ;
        !           430: ; We can compile the form just like an eq form since all we want is
        !           431: ; a compare and a jump.  The comparisons are inverted since that is
        !           432: ; the way eq expects it.
        !           433: 
        !           434: (defun cc-<& nil
        !           435:    (let ((g-trueop  #+for-vax 'jgeq #+for-68k 'jpl)
        !           436:         (g-falseop #+for-vax 'jlss #+for-68k 'jmi)
        !           437:         (v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
        !           438:       (cc-eq)))
        !           439: 
        !           440: ;--- cm->  :: compile a > expression
        !           441: ;
        !           442: ; the operands to this form can either be fixnum or flonums but they
        !           443: ; must be of the same type.  
        !           444: ; We can compile the form just like an eq form since all we want is
        !           445: ; a compare and a jump.  The comparisons are inverted since that is
        !           446: ; the way eq expects it.
        !           447: (defun cm-> nil
        !           448:    (if (not (= 2 (length (cdr v-form))))
        !           449:       then (comp-err "incorrect number of arguments to > " v-form))
        !           450:    ; only can do fixnum stuff if we know that one of the args is
        !           451:    ; a fixnum.
        !           452:    ;
        !           453:    (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
        !           454:       then `(>& ,(cadr v-form) ,(caddr v-form))
        !           455:       else `(greaterp ,(cadr v-form) ,(caddr v-form))))
        !           456: 
        !           457: ;--- cc->& :: compile a fixnum > function
        !           458: ;
        !           459: ; We can compile the form just like an eq form since all we want is
        !           460: ; a compare and a jump.  The comparisons are inverted since that is
        !           461: ; the way eq expects it.
        !           462: (defun cc->& nil
        !           463:    (let ((g-trueop  #+for-vax 'jleq #+for-68k 'jle)
        !           464:         (g-falseop #+for-vax 'jgtr #+for-68k 'jgt)
        !           465:         (v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
        !           466:       (cc-eq)))
        !           467: 
        !           468: ;--- cm-=  : compile an = expression
        !           469: ;  The = function is a strange one.  It can compare two fixnums or two
        !           470: ; flonums which is fine on a pdp-10 where they are the same size, but
        !           471: ; is a real pain on a vax where they are different sizes.
        !           472: ; We thus can see if one of the arguments is a fixnum and assume that
        !           473: ; the other one is and then  call =&, the fixnum equal code.
        !           474: ;
        !           475: (defun cm-= nil
        !           476:    (if (not (= 2 (length (cdr v-form))))
        !           477:       then (comp-err "incorrect number of arguments to = : " v-form))
        !           478:    (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
        !           479:       then `(=& ,(cadr v-form) ,(caddr v-form))
        !           480:       else `(equal ,(cadr v-form) ,(caddr v-form))))
        !           481: 
        !           482: ;--- cm-=&
        !           483: ;
        !           484: ; if the number is within the small fixnum range, we can just
        !           485: ; do pointer comparisons.
        !           486: ;
        !           487: (defun cm-=& nil
        !           488:    (if (or (and (fixp (cadr v-form))
        !           489:                (< (cadr v-form) 1024)
        !           490:                (> (cadr v-form) -1025))
        !           491:           (and (fixp (caddr v-form))
        !           492:                (< (caddr v-form) 1024)
        !           493:                (> (caddr v-form) -1025)))
        !           494:       then `(eq ,(cadr v-form) ,(caddr v-form))
        !           495:       else `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
        !           496: 
        !           497: ; this should be converted
        !           498: #+for-vax
        !           499: (defun c-\\ nil
        !           500:    (d-fixop 'ediv  'remainder))
        !           501: 
        !           502: #+for-vax
        !           503: (defun d-fixop (opcode lispopcode)
        !           504:    (prog (op1 op2 rop1 rop2 simpleop1)
        !           505:        (if (not (eq 3 (length v-form))) ; only handle two ops for now
        !           506:           then (d-callbig lispopcode (cdr v-form) nil)
        !           507:           else (setq op1 (cadr v-form)
        !           508:                      op2 (caddr v-form))
        !           509:                (if (fixp op1)
        !           510:                    then (setq rop1 `($ ,op1)  ; simple int
        !           511:                               simpleop1 t)         
        !           512:                    else (if (setq rop1 (d-simple `(cdr ,op1)))
        !           513:                             then (setq rop1 (e-cvt rop1))
        !           514:                             else (let ((g-loc 'reg) g-cc g-ret)
        !           515:                                      (d-exp op1))
        !           516:                                  (setq rop1 '(0 r0))))
        !           517:                (if (fixp op2)
        !           518:                    then (setq rop2 `($ ,op2))
        !           519:                    else (if (setq rop2 (d-simple `(cdr ,op2)))
        !           520:                             then (setq rop2 (e-cvt rop2))
        !           521:                             else (C-push rop1)
        !           522:                                  (setq rop1 '#.unCstack)
        !           523:                                  (let ((g-loc 'reg)
        !           524:                                        g-cc g-ret)
        !           525:                                      (d-exp op2))
        !           526:                                  (setq rop2 '(0 r0))))
        !           527:                (if (eq opcode 'ediv)
        !           528:                    then (if (not simpleop1)
        !           529:                             then (e-move rop1 'r2)  ; need quad
        !           530:                                  (e-write4 'ashq '$-32 'r1 'r1)
        !           531:                                  (setq rop1 'r1))      ; word div.
        !           532:                         (e-write5 'ediv rop2 rop1 'r0 'r5)
        !           533:                    else (e-write4 opcode rop2 rop1 'r5))
        !           534:                (d-fixnumbox)
        !           535:                (d-clearreg))))

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