Return to expr.l CVS log

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

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

1.1     ! root        1: (include-if (null (get 'chead 'version)) "../chead.l")
        !             2: (Liszt-file expr
        !             3:    "$Header: expr.l,v 1.13 87/12/15 17:01:08 sklower Exp $")
        !             4: 
        !             5: ;;; ----       e x p r                         expression compilation
        !             6: ;;;
        !             7: ;;;                            -[Fri Sep  2 22:10:20 1983 by layer]-
        !             8: 
        !             9: 
        !            10: ;--- d-exp :: compile a lisp expression
        !            11: ;      v-form : a lisp expression to compile
        !            12: ; returns an IADR which tells where the value was located.
        !            13: ;
        !            14: 
        !            15: (defun d-exp (v-form)
        !            16:   (prog (first resloc tmp ftyp nomacrop)
        !            17:     begin
        !            18:        (if (atom v-form)
        !            19:            then (setq tmp (d-loc v-form))              ;locate vrble
        !            20:                 (if (null g-loc)
        !            21:                     then (if g-cc then (d-cmpnil tmp))
        !            22:                    else (d-move tmp g-loc)
        !            23:                         #+for-68k (if g-cc then (d-cmpnil tmp)))
        !            24:                 (d-handlecc)
        !            25:                 (return tmp)
        !            26: 
        !            27:         elseif (atom (setq first (car v-form)))
        !            28:           then ; the form (*no-macroexpand* <expr>)
        !            29:                ; turns into <expr>, and prevents <expr> from
        !            30:                ; being macroexpanded (at the top level)
        !            31:                (if (eq '*no-macroexpand* first)
        !            32:                   then (setq v-form (cadr v-form)
        !            33:                              nomacrop t)
        !            34:                        (go begin))
        !            35:                (if (and fl-xref (not (get first g-refseen)))
        !            36:                     then (Push g-reflst first)
        !            37:                          (putprop first t g-refseen))
        !            38:                 (setq ftyp (d-functyp first (if nomacrop then nil
        !            39:                                                else 'macros-ok)))
        !            40:                 ; if nomacrop is t, then under no circumstances
        !            41:                 ; permit the form to be macroexpanded
        !            42:                 (if (and nomacrop (eq ftyp 'macro))
        !            43:                     then (setq ftyp 'lambda))
        !            44:                 ; If the resulting form is type macro or cmacro,
        !            45:                 ; then call the appropriate function to macro-expand
        !            46:                 ; it.
        !            47:                 (if (memq ftyp '(macro cmacro))
        !            48:                    then (setq tmp v-form)      ; remember original form
        !            49:                         (if (eq 'macro ftyp)
        !            50:                             then (setq v-form (apply first v-form))
        !            51:                           elseif (eq 'cmacro ftyp)
        !            52:                             then (setq v-form (apply (get first 'cmacro)
        !            53:                                                      v-form)))
        !            54:                          ; If the resulting form is the same as
        !            55:                          ; the original form, then we don't want to
        !            56:                          ; macro expand again.  We call d-functyp and tell
        !            57:                          ; it that we want a second opinion
        !            58:                          (if (and (eq (car v-form) first)
        !            59:                                   (equal tmp v-form))
        !            60:                             then (setq ftyp (d-functyp first nil))
        !            61:                             else (go begin))) ; retry with what we have
        !            62: 
        !            63:                 (if (and (setq tmp (get first 'if-fixnum-args))
        !            64:                              (d-allfixnumargs (cdr v-form)))
        !            65:                    then (setq v-form (cons tmp (cdr v-form)))
        !            66:                         (go begin)
        !            67:                  elseif (setq tmp (get first 'fl-exprcc))
        !            68:                    then (d-argnumchk 'hard)
        !            69:                         (return (funcall tmp))
        !            70:                  elseif (setq tmp (get first 'fl-exprm))
        !            71:                    then (d-argnumchk 'hard)
        !            72:                         (setq v-form (funcall tmp))
        !            73:                         (go begin)
        !            74:                  elseif (setq tmp (get first 'fl-expr))
        !            75:                    then (d-argnumchk 'hard)
        !            76:                         (funcall tmp)
        !            77:                  elseif (setq tmp (or (and (eq 'car first)
        !            78:                                            '( a ))
        !            79:                                       (and (eq 'cdr first)
        !            80:                                            '( d ))
        !            81:                                       (d-cxxr first)))
        !            82:                    then (d-argcheckit '(1 . 1) (length (cdr v-form)) 'hard)
        !            83:                         (return (cc-cxxr (cadr v-form) tmp))
        !            84:                   elseif (eq 'nlambda ftyp)
        !            85:                    then (d-argnumchk 'soft)
        !            86:                         (d-callbig first `(',(cdr v-form)) nil)
        !            87:                   elseif (or (eq 'lambda ftyp) (eq 'lexpr ftyp))
        !            88:                     then (setq tmp (length v-form))
        !            89:                          (d-argnumchk 'soft)
        !            90:                          (d-callbig first (cdr v-form) nil)
        !            91:                   elseif (eq 'array ftyp)
        !            92:                    then (d-handlearrayref)
        !            93:                  elseif (eq 'macro ftyp)
        !            94:                    then (comp-err "infinite macro expansion " v-form)
        !            95:                    else (comp-err "internal liszt err in d-exp" v-form))
        !            96: 
        !            97:         elseif (eq 'lambda (car first))
        !            98:            then (c-lambexp)
        !            99: 
        !           100:         elseif (or (eq 'quote (car first)) (eq 'function (car first)))
        !           101:            then (comp-warn "bizzare function name " (or first))
        !           102:                 (setq v-form (cons (cadr first) (cdr v-form)))
        !           103:                 (go begin)
        !           104:                
        !           105:         else (comp-err "bad expression" (or v-form)))
        !           106: 
        !           107:        (if (null g-loc)
        !           108:            then (if g-cc then (d-cmpnil 'reg))
        !           109:         elseif (memq g-loc '(reg #+(or for-vax for-tahoe) r0 #+for-68k d0))
        !           110:            then (if g-cc then (d-cmpnil 'reg))
        !           111:           else (d-move 'reg g-loc)
        !           112:                #+for-68k (if g-cc then (d-cmpnil 'reg)))
        !           113:        (if g-cc then (d-handlecc))))
        !           114: 
        !           115: ;--- d-exps :: compile a list of expressions
        !           116: ;      - exps : list of expressions
        !           117: ; the last expression is evaluated according to g-loc and g-cc, the others
        !           118: ; are evaluated with g-loc and g-cc nil.
        !           119: ;
        !           120: (defun d-exps (exps)
        !           121:   (d-exp (do ((ll exps (cdr ll))
        !           122:              (g-loc nil)
        !           123:              (g-cc  nil)
        !           124:              (g-ret nil))
        !           125:             ((null (cdr ll)) (car ll))
        !           126:             (d-exp (car ll)))))
        !           127: 
        !           128: 
        !           129: ;--- d-argnumchk :: check that the correct number of arguments are given
        !           130: ; v-form (global) contains the expression to check
        !           131: ; class: hard or soft, hard means that failure is an error, soft means
        !           132: ;      warning
        !           133: (defun d-argnumchk (class)
        !           134:    (let ((info (car (get (car v-form) 'fcn-info)))
        !           135:         (argsize (length (cdr v-form))))
        !           136:       (if info then (d-argcheckit info argsize class))))
        !           137: 
        !           138: ;--- d-argcheckit
        !           139: ; info - arg information form:  (min# . max#)  max# of nil means no max
        !           140: ; numargs - number of arguments given
        !           141: ; class - hard or soft
        !           142: ; v-form(global) - expression begin checked
        !           143: ;
        !           144: (defun d-argcheckit (info numargs class)
        !           145:    (if (and (car info) (< numargs (car info)))
        !           146:       then (if (eq class 'hard)
        !           147:              then (comp-err
        !           148:                      (difference (car info) numargs)
        !           149:                      " too few argument(s) given in this expression:" N
        !           150:                      v-form)
        !           151:              else (comp-warn
        !           152:                      (difference (car info) numargs)
        !           153:                      " too few argument(s) given in this expression:" N
        !           154:                      v-form))
        !           155:     elseif (and (cdr info) (> numargs (cdr info)))
        !           156:       then (if (eq class 'hard)
        !           157:              then (comp-err
        !           158:                      (difference numargs (cdr info))
        !           159:                      " too many argument(s) given in this expression:" N
        !           160:                      v-form)
        !           161:              else (comp-warn
        !           162:                      (difference numargs (cdr info))
        !           163:                      " too many argument(s) given in this expression:" N
        !           164:                      v-form))))
        !           165: 
        !           166: ;--- d-pushargs :: compile and push a list of expressions
        !           167: ;      - exps : list of expressions
        !           168: ; compiles and stacks a list of expressions
        !           169: ;
        !           170: (defun d-pushargs (args)
        !           171:    (if args then
        !           172:        (do ((ll args (cdr ll))
        !           173:            (g-loc 'stack)
        !           174:            (g-cc nil)
        !           175:            (g-ret nil))
        !           176:           ((null ll))
        !           177:           (d-exp (car ll))
        !           178:           (push nil g-locs)
        !           179:           (incr g-loccnt))))
        !           180: 
        !           181: ;--- d-cxxr :: split apart a cxxr function name
        !           182: ;      - name : a possible cxxr function name
        !           183: ; returns the a's and d's between c and r in reverse order, or else
        !           184: ;  returns nil if this is not a cxxr name
        !           185: ;
        !           186: (defun d-cxxr (name)
        !           187:   (let ((expl (explodec name)))
        !           188:        (if (eq 'c (car expl))                  ; must begin with c
        !           189:           then (do ((ll (cdr expl) (cdr ll))
        !           190:                     (tmp)
        !           191:                     (res))
        !           192:                    (nil)
        !           193:                    (setq tmp (car ll))
        !           194:                    (if (null (cdr ll)) 
        !           195:                        then (if (eq 'r tmp)    ; must end in r
        !           196:                                 then (return res)
        !           197:                                 else (return nil))
        !           198:                     elseif (or (eq 'a tmp)     ; and contain only a's and d's
        !           199:                                (eq 'd tmp))
        !           200:                        then (setq res (cons tmp res))
        !           201:                     else (return nil))))))
        !           202: 
        !           203: 
        !           204: ;--- d-callbig :: call a local, global or bcd  function        
        !           205: ;
        !           206: ; name is the name of the function we are to call
        !           207: ; args are the arguments to evaluate and call the function with
        !           208: ; if bcdp is t then we are calling through a binary object and thus
        !           209: ; name is ingored.
        !           210: ;
        !           211: #+(or for-vax for-tahoe)
        !           212: (defun d-callbig (name args bcdp)
        !           213:   (let ((tmp (get name g-localf))
        !           214:        c)
        !           215:        (forcecomment `(calling ,name))
        !           216:        (if (d-dotailrecursion name args) thenret
        !           217:         elseif tmp then ;-- local function call
        !           218:                    (d-pushargs args)
        !           219:                    (e-quick-call (car tmp))
        !           220:                    (setq g-locs (nthcdr (setq c (length args)) g-locs))
        !           221:                    (setq g-loccnt (- g-loccnt c))
        !           222:        else (if bcdp           ;-- bcdcall
        !           223:                 then (d-pushargs args)
        !           224:                      (setq c (length args))
        !           225:                      (d-bcdcall c)
        !           226:               elseif fl-tran   ;-- transfer table linkage
        !           227:                 then (d-pushargs args)
        !           228:                    (setq c (length args))
        !           229:                    (d-calltran name c)
        !           230:                    (putprop name t g-stdref)   ; remember we've called this
        !           231:               else ;--- shouldn't get here
        !           232:                    (comp-err " bad args to d-callbig : "
        !           233:                              (or name args)))
        !           234:             (setq g-locs (nthcdr c g-locs))
        !           235:             (setq g-loccnt (- g-loccnt c)))
        !           236:        (d-clearreg)))
        !           237: 
        !           238: #+for-68k
        !           239: (defun d-callbig (name args bcdp)
        !           240:   (let ((tmp (get name g-localf))
        !           241:        c)
        !           242:        (forcecomment `(calling ,name))
        !           243:        (if (d-dotailrecursion name args)
        !           244:           thenret
        !           245:         elseif tmp then ;-- local function call
        !           246:                    (d-pushargs args)
        !           247:                    (setq c (length args))
        !           248:                    (if (null $global-reg$) then
        !           249:                        (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
        !           250:                        (e-move 'a5 '#.lbot-sym)
        !           251:                        (e-move '#.np-reg '#.np-sym))
        !           252:                    (e-quick-call (car tmp))
        !           253:                    (setq g-locs (nthcdr c g-locs))
        !           254:                    (setq g-loccnt (- g-loccnt c))
        !           255:        else (if bcdp           ;-- bcdcall
        !           256:                 then (d-pushargs args)
        !           257:                      (setq c (length args))
        !           258:                      (d-bcdcall c)
        !           259:               elseif fl-tran   ;-- transfer table linkage
        !           260:                 then (d-pushargs args)
        !           261:                    (setq c (length args))
        !           262:                    (d-calltran name c)
        !           263:                    (putprop name t g-stdref)   ; remember we've called this
        !           264:               else ;--- shouldn't get here
        !           265:                    (comp-err " bad args to d-callbig : "
        !           266:                              (or name args)))
        !           267:             (setq g-locs (nthcdr c g-locs))
        !           268:             (setq g-loccnt (- g-loccnt c)))
        !           269:        (d-clearreg)))
        !           270: 
        !           271: ;--- d-calltran :: call a function through the transfer table
        !           272: ;  name - name of function to call
        !           273: ;  c - number of arguments to the function
        !           274: ;
        !           275: #+(or for-vax for-tahoe)
        !           276: (defun d-calltran (name c)
        !           277:    (if $global-reg$
        !           278:        then (e-write3 'movab `(,(* -4 c) #.np-reg) '#.lbot-reg)
        !           279:        else (e-write3 'movab `(,(* -4 c) #.np-reg) '#.lbot-sym)
        !           280:            (e-move '#.np-reg '#.np-sym))
        !           281:    #+for-vax (e-write3 'calls '$0 (concat "*trantb+" (d-tranloc name)))
        !           282:    #+for-tahoe (progn (e-write3 'movab (concat "trantb+" (d-tranloc name)) 'r2)
        !           283:                      (e-write3 'calls '$4 '"*(r2)"))
        !           284:    (if $global-reg$
        !           285:        then (e-move '#.lbot-reg '#.np-reg)
        !           286:        else (e-write3 'movab `(,(* -4 c) #.np-reg) '#.np-reg)))
        !           287: 
        !           288: #+for-68k
        !           289: (defun d-calltran (name c)
        !           290:    (if $global-reg$
        !           291:        then (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
        !           292:            (e-move 'a5 '#.lbot-reg)
        !           293:        else (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
        !           294:            (e-move 'a5 '#.lbot-sym)
        !           295:            (e-move '#.np-reg '#.np-sym))
        !           296:    (e-move (concat "trantb+" (d-tranloc name)) 'a5)
        !           297:    (e-quick-call '(0 a5))
        !           298:    (if $global-reg$
        !           299:        then (e-move '#.lbot-reg '#.np-reg)
        !           300:        else (e-write3 'lea `(,(* -4 c) #.np-reg) '#.np-reg)))
        !           301: 
        !           302: ;--- d-calldirect :: call a function directly
        !           303: ;
        !           304: ;  name - name of a function in the C code (known about by fasl)
        !           305: ;    c  - number of args
        !           306: ;
        !           307: #+(or for-vax for-tahoe)
        !           308: (defun d-calldirect (name c)
        !           309:    (if $global-reg$
        !           310:        then (e-write3 'movab `(,(* -4 c) #.np-reg) '#.lbot-reg)
        !           311:        else (e-write3 'movab `(,(* -4 c) #.np-reg) '#.lbot-sym)
        !           312:            (e-move '#.np-reg '#.np-sym))
        !           313: #+for-vax (e-write3 'calls '$0  name)
        !           314: #+for-tahoe (e-write3 'callf '$4  name)
        !           315:    (if $global-reg$
        !           316:        then (e-move '#.lbot-reg '#.np-reg)
        !           317:        else (e-write3 'movab `(,(* -4 c) #.np-reg) '#.np-reg)))
        !           318: 
        !           319: #+for-68k
        !           320: (defun d-calldirect (name c)
        !           321:    (if $global-reg$
        !           322:        then (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
        !           323:            (e-move 'a5 '#.lbot-reg)
        !           324:        else (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
        !           325:            (e-move 'a5 '#.lbot-sym)
        !           326:            (e-move '#.np-reg '#.np-sym))
        !           327:    (e-quick-call name)
        !           328:    (if $global-reg$
        !           329:        then (e-move '#.lbot-reg '#.np-reg)
        !           330:        else (e-write3 'lea `(,(* -4 c) #.np-reg) '#.np-reg)))
        !           331: 
        !           332: ;--- d-bcdcall :: call a function through a binary data object
        !           333: ;  
        !           334: ; at this point the stack contains n-1 arguments and a binary object which
        !           335: ; is the address of the compiled lambda expression to go to.  We set
        !           336: ; up lbot right above the binary on the stack and call the function.
        !           337: ;
        !           338: #+(or for-vax for-tahoe)
        !           339: (defun d-bcdcall (n)
        !           340:    (if $global-reg$
        !           341:        then (e-write3 'movab `(,(* -4 (- n 1)) #.np-reg) '#.lbot-reg)
        !           342:        else (e-write3 'movab `(,(* -4 (- n 1)) #.np-reg) '#.lbot-sym)
        !           343:            (e-move '#.np-reg '#.np-sym))
        !           344:    (e-move  `(* ,(* -4 n) #.np-reg) 'r0)    ;get address to call to
        !           345: #+for-vax   (e-write3 'calls '$0 "(r0)")
        !           346: #+for-tahoe (e-write3 'calls '$4 "(r0)")
        !           347:    (if $global-reg$
        !           348:        then (e-write3 'movab '(-4 #.lbot-reg) '#.np-reg)
        !           349:        else (e-write3 'movab `(,(* -4 n) #.np-reg) '#.np-reg)))
        !           350: 
        !           351: #+for-68k
        !           352: (defun d-bcdcall (n)
        !           353:    (if $global-reg$
        !           354:        then (e-write3 'lea `(,(* -4 (- n 1)) #.np-reg) 'a5)
        !           355:            (e-move 'a5 '#.lbot-reg)
        !           356:        else (e-write3 'lea `(,(* -4 (- n 1)) #.np-reg) 'a5)
        !           357:            (e-move 'a5 '#.lbot-sym)
        !           358:            (e-move '#.np-reg '#.np-sym))
        !           359:    (e-move `(,(* -4 n) #.np-reg) 'a5)  ; get address to call to
        !           360:    (e-move `(0 a5) 'a5)
        !           361:    (e-quick-call '(0 a5))
        !           362:    (if $global-reg$
        !           363:        then (e-move '#.lbot-reg 'a5)
        !           364:            (e-write3 'lea '(-4 a5) '#.np-reg)
        !           365:        else (e-write3 'lea `(,(* -4 n) #.np-reg) '#.np-reg)))
        !           366: 
        !           367: ;--- d-dotailrecursion :: do tail recursion if possible
        !           368: ; name - function name we are to call
        !           369: ; args - arguments to give to function
        !           370: ;
        !           371: ; return t iff we were able to do tail recursion
        !           372: ; We can do tail recursion if:
        !           373: ;  g-ret is set indicating that the result of this call will be returned
        !           374: ;       as the value of the function we are compiling
        !           375: ;  the function we are calling, name, is the same as the function we are
        !           376: ;       compiling, g-fname
        !           377: ;  there are no variables shallow bound, since we would have to unbind
        !           378: ;       them, which may cause problems in the function.
        !           379: ;
        !           380: (defun d-dotailrecursion (name args)
        !           381:    (prog (nargs lbot)
        !           382:        (if (null (and g-ret
        !           383:                      (eq name g-fname)
        !           384:                      (do ((loccnt 0)
        !           385:                           (ll g-locs (cdr ll)))
        !           386:                          ((null ll) (return t))
        !           387:                          (if (dtpr (car ll))
        !           388:                              then (if (or (eq 'catcherrset (caar ll))
        !           389:                                           (greaterp (cdar ll) 0))
        !           390:                                       then (return nil))
        !           391:                              else (incr loccnt)))))
        !           392:           then (return nil))
        !           393: 
        !           394:        (makecomment '(tail merging))
        !           395:        (comp-note g-fname ": Tail merging being done: " v-form)
        !           396: 
        !           397:        (setq nargs (length args))
        !           398:        
        !           399:        ; evalate the arguments, putting them above the arguments to the
        !           400:        ; function we are executing...
        !           401:        (let ((g-locs g-locs)
        !           402:             (g-loccnt g-loccnt))
        !           403:           (d-pushargs args))
        !           404: 
        !           405:        (if $global-reg$
        !           406:           then (setq lbot #+for-68k 'a5 #+(or for-vax for-tahoe) '#.lbot-reg)
        !           407:                #+for-68k (e-move '#.lbot-reg lbot)
        !           408:           else (setq lbot #+for-68k 'a5 #+(or for-vax for-tahoe) '#.fixnum-reg)
        !           409:                (e-move '#.lbot-sym lbot))
        !           410: 
        !           411:        ; setup lbot-reg to point to the bottom of the original
        !           412:        ;args...
        !           413:        (if (eq 'lexpr g-ftype)
        !           414:           then #+for-vax
        !           415:                (e-write4 'ashl '($ 2) '(* -4 #.olbot-reg) lbot)
        !           416:                #+for-tahoe
        !           417:                (e-write4 'shal '($ 2) '(* -4 #.olbot-reg) lbot)
        !           418:                #+for-68k
        !           419:                (progn
        !           420:                 (d-regused 'd6)
        !           421:                 (e-move '(* -4 #.olbot-reg) 'd6)
        !           422:                 (e-write3 'asll '($ 2) 'd6)
        !           423:                 (e-move 'd6 lbot))
        !           424:                (e-sub lbot '#.olbot-reg)
        !           425:                (e-sub3 '($ 4) '#.olbot-reg lbot)
        !           426:           else (e-move '#.olbot-reg lbot))
        !           427: 
        !           428:        ; copy the new args down into the place of the original ones...
        !           429:        (do ((i nargs (1- i))
        !           430:            (off-top (* nargs -4) (+ off-top 4))
        !           431:            (off-bot 0 (+ off-bot 4)))
        !           432:           ((zerop i))
        !           433:           (e-move `(,off-top #.np-reg) `(,off-bot ,lbot)))
        !           434: 
        !           435:        ; setup np for the coming call...
        !           436:        (e-add3 `($ ,(* 4 nargs)) lbot '#.np-reg)
        !           437: 
        !           438:        (e-goto g-topsym)
        !           439:        ;return t to indicate that tailrecursion was successful
        !           440:        (return t)))

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