home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / lisp / liszt / expr.l < prev    next >
Encoding:
Text File  |  1987-12-15  |  14.3 KB  |  441 lines
  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)))
  441.