home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpeval.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  23.5 KB  |  667 lines
  1. ;;; CMPEVAL  The Expression Dispatcher.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22.  
  23.  
  24. (export '(si::define-compiler-macro
  25.       si::undef-compiler-macro
  26.           si::define-inline-function) 'system)
  27.  
  28. (in-package 'compiler)
  29.  
  30. (si:putprop 'progn 'c1progn 'c1special)
  31. (si:putprop 'progn 'c2progn 'c2)
  32.  
  33. (si:putprop 'si:structure-ref 'c1structure-ref 'c1)
  34. (si:putprop 'structure-ref 'c2structure-ref 'c2)
  35. (si:putprop 'structure-ref 'wt-structure-ref 'wt-loc)
  36. (si:putprop 'si:structure-set 'c1structure-set 'c1)
  37. (si:putprop 'structure-set 'c2structure-set 'c2)
  38.  
  39. (defun c1expr* (form info)
  40.   (setq form (c1expr form))
  41.   (add-info info (cadr form))
  42.   form)
  43.  
  44. (defun c1expr (form)
  45.   (setq form (catch *cmperr-tag*
  46.     (cond ((symbolp form)
  47.            (cond ((eq form nil) (c1nil))
  48.                  ((eq form t) (c1t))
  49.                  ((keywordp form)
  50.                   (list 'LOCATION (make-info :type (object-type form))
  51.                         (list 'VV (add-object form))))
  52.                  ((constantp form)
  53.                   (let ((val (symbol-value form)))
  54.                     (or (c1constant-value val nil)
  55.                         (list 'LOCATION (make-info :type (object-type val))
  56.                               (list 'VV (add-constant form))))))
  57.                  (t (c1var form))))
  58.           ((consp form)
  59.            (let ((fun (car form)))
  60.              (cond ((symbolp fun)
  61.                     (c1symbol-fun fun (cdr form)))
  62.                    ((and (consp fun) (eq (car fun) 'lambda))
  63.                     (c1lambda-fun (cdr fun) (cdr form)))
  64.                    ((and (consp fun) (eq (car fun) 'si:|#,|))
  65.                     (cmperr "Sharp-comma-macro was found in a bad place."))
  66.                    (t (cmperr "The function ~s is illegal." fun)))))
  67.           (t (c1constant-value form t)))))
  68.   (if (eq form '*cmperr-tag*) (c1nil) form))
  69.  
  70. (si::putprop 'si:|#,| 'c1sharp-comma 'c1special)
  71.  
  72. (defun c1sharp-comma (arg)
  73.   (c1constant-value (cons 'si:|#,| arg) t))
  74.  
  75. (si::putprop 'si::define-structure 'c1define-structure 't1)
  76.  
  77. (defun c1define-structure (arg &aux *sharp-commas*)
  78.   (declare (special *sharp-commas*))
  79.   (eval (cons 'si::define-structure arg))
  80.   (c1constant-value (cons 'si:|#,| (cons 'si::define-structure arg)) t)
  81.   (add-load-time-sharp-comma)
  82.   nil)
  83.  
  84. (defvar *c1nil* (list 'LOCATION (make-info :type (object-type nil)) nil))
  85. (defun c1nil () *c1nil*)
  86. (defvar *c1t* (list 'LOCATION (make-info :type (object-type t)) t))
  87. (defun c1t () *c1t*)
  88.  
  89.  
  90. (defun flags-pos (flag &aux (i 0))
  91.   (declare (fixnum i))
  92.   (dolist
  93.       (v
  94.        '((allocates-new-storage ans); might invoke gbc
  95.      (side-effect-p set)        ; no effect on arguments
  96.      (constantp)                ; always returns same result,
  97.                                 ;double eval ok.
  98.      (result-type-from-args rfa); if passed args of matching
  99.                     ;type result is of result type
  100.          (is)))                     ;; extends the `integer stack'.
  101.     (cond ((member flag v :test 'eq)
  102.        (return-from flags-pos i)))
  103.     (setq i (+ i 1)))
  104.   (error "unknown opt flag"))
  105.  
  106. (defmacro flag-p (n flag)
  107.   `(logbitp ,(flags-pos  flag)  ,n))
  108.  
  109. ;; old style opts had '(args ret new-storage side-effect string)
  110. ;; these new-storage and side-effect have been combined into
  111. ;; one integer, along with several other flags.
  112.  
  113. (defun fix-opt (opt)
  114.   (let ((a (cddr opt)))
  115.     (unless (typep (car a ) 'fixnum)
  116.     (if *compiler-in-use*
  117.     (cmpwarn "Obsolete optimization: use fix-opt ~s"  opt))
  118.              
  119.     (setf (cddr opt)
  120.       (cons (logior (if (car a) 2 0)
  121.             (if (cadr a) 1 0))
  122.         (cddr a))))
  123.     opt))
  124.  
  125. ;; some hacks for revising a list of optimizers.
  126. #+revise
  127. (progn
  128. (defun output-opt (opt sym flag)
  129.   (fix-opt opt)
  130.   (format t "(push '(~(~s ~s #.(flags~)" (car opt) (second opt))
  131.   (let ((o (third opt)))
  132.     (if (flag-p o set) (princ " set"))
  133.     (if (flag-p o ans) (princ " ans"))
  134.     (if (flag-p o rfa) (princ " rfa"))
  135.     (if (flag-p o constantp) (princ "constantp ")))
  136.   (format t ")")
  137.   (if (and (stringp (nth 3 opt))
  138.        (> (length (nth 3 opt)) 40))
  139.       (format t "~%  "))
  140.   (prin1 (nth 3 opt))
  141.   (format t ")~%   ~((get '~s '~s)~))~%"  sym flag))
  142.  
  143. (defun output-all-opts (&aux  lis did)
  144.   (sloop::sloop
  145.    for v in ;(list (find-package "LISP"))
  146.                     (list-all-packages)
  147.    do
  148.    (setq lis
  149.      (sloop::sloop
  150.       for sym in-package (package-name v)
  151.       when (or (get sym 'inline-always)
  152.            (get sym 'inline-safe)
  153.            (get sym 'inline-unsafe))
  154.       collect sym))
  155.    (setq lis (sort lis #'(lambda (x y) (string-lessp (symbol-name x)
  156.                               (symbol-name y)))))
  157.    do
  158.    (sloop::sloop for sym in lis do
  159.          (format t "~%;;~s~% " sym)
  160.        (sloop::sloop for u in '(inline-always inline-safe inline-unsafe)
  161.              do (sloop::sloop
  162.              for w in (reverse (remove-duplicates
  163.                         (copy-list (get sym u))
  164.                         :test 'equal))
  165.              do (output-opt w  sym u))))))
  166.  
  167. )                      
  168.                 
  169.  
  170. (defun result-type-from-args(f args &aux tem)
  171.   (when (and (setq tem (get f 'return-type))
  172.              (not (eq tem '*))
  173.          (not (consp tem)))
  174.     (dolist (v '(inline-always inline-unsafe))
  175.       (dolist (w (get f v))
  176.     (fix-opt w)
  177.     (when (and
  178.            (flag-p (third w) result-type-from-args)
  179.            (eql (length args) (length (car w)))
  180.            (do ((a args (cdr a))
  181.             (b (car w) (cdr b)))
  182.            ((null a) t)
  183.          (unless (or  (eq (car a) (car b))
  184.                   (type>= (car b)(car a) ))
  185.              (return nil))))
  186.       (return-from result-type-from-args (second w)))))))
  187.               
  188.  
  189. ;; omitting a flag means it is set to nil.
  190. (defmacro flags (&rest lis &aux (i 0))
  191.   (dolist (v lis)
  192.     (setq i (logior  i (ash 1 (flags-pos v)))))
  193.   i)
  194.  
  195. ;; Usage:
  196. ; (flagp-p (caddr ii) side-effect-p)
  197. ; (push '((integer integer) integer #.(flags const raf) "addii(#0,#1)")
  198. ;         (get '+ 'inline-always))
  199.  
  200.  
  201.  
  202. (defun c1symbol-fun (fname args &aux fd)
  203.   (cond ((setq fd (get fname 'c1special)) (funcall fd args))
  204.     ((and (setq fd (get fname 'co1special))
  205.           (funcall fd fname args)))
  206.         ((setq fd (c1local-fun fname))
  207.          (if (eq (car fd) 'call-local)
  208.              (let* ((info (make-info :sp-change t))
  209.                     (forms (c1args args info)))
  210.                   (let ((return-type (get-local-return-type (caddr fd))))
  211.                        (when return-type (setf (info-type info) return-type)))
  212.                   (let ((arg-types (get-local-arg-types (caddr fd))))
  213.                        ;;; Add type information to the arguments.
  214.                        (when arg-types
  215.                              (let ((fl nil))
  216.                                   (dolist** (form forms)
  217.                                     (cond ((endp arg-types) (push form fl))
  218.                                           (t (push (and-form-type
  219.                                                     (car arg-types) form
  220.                                                     (car args))
  221.                                                    fl)
  222.                                              (pop arg-types)
  223.                                              (pop args))))
  224.                                   (setq forms (reverse fl)))))
  225.                   (list 'call-local info (cddr fd) forms))
  226.              (c1expr (cmp-expand-macro fd fname args))))
  227.     ((and (setq fd (get fname 'co1))
  228.           (inline-possible fname)
  229.           (funcall fd fname args)))
  230.         ((and (setq fd (get fname 'c1)) (inline-possible fname))
  231.          (funcall fd args))
  232.         ((and (setq fd (get fname 'c1conditional))
  233.               (inline-possible fname)
  234.               (funcall (car fd) args))
  235.          (funcall (cdr fd) args))
  236.     ;; record the call info if we get to here
  237.     ((progn
  238.        (and (eq (symbol-package fname) (symbol-package 'and))
  239.         (not (fboundp fname))
  240.         (cmpwarn "~A (in lisp package) is called as a function--not yet defined"
  241.              fname))
  242.        (and *record-call-info* (record-call-info 'record-call-info
  243.                            fname))
  244.        nil))
  245.     ;;continue
  246.         ((setq fd (macro-function fname))
  247.          (c1expr (cmp-expand-macro fd fname args)))
  248.         ((setq fd (get fname 'compiler-macro))
  249.          (c1expr (cmp-eval `(funcall ',fd ',(cons fname args) nil))))
  250.         ((and (setq fd (get fname 'si::structure-access))
  251.               (inline-possible fname)
  252.               ;;; Structure hack.
  253.               (consp fd)
  254.               (si:fixnump (cdr fd))
  255.               (not (endp args))
  256.               (endp (cdr args)))
  257.          (case (car fd)
  258.                (vector (c1expr `(elt ,(car args) ,(cdr fd))))
  259.                (list (c1expr `(si:list-nth ,(cdr fd) ,(car args))))
  260.                (t (c1structure-ref1 (car args) (car fd) (cdr fd)))
  261.                )
  262.          )
  263.         ((eq fname 'si:|#,|)
  264.          (cmperr "Sharp-comma-macro was found in a bad place."))
  265.         (t (let* ((info (make-info
  266.                         :sp-change (null (get fname 'no-sp-change))))
  267.                   (forms (c1args args info)))
  268.                 (let ((return-type (get-return-type fname)))
  269.           (when return-type
  270.             (if (equal return-type '(*))
  271.                 (setf return-type nil)
  272.             (setf (info-type info) return-type))))
  273.                 (let ((arg-types (get-arg-types fname)))
  274.                      ;;; Add type information to the arguments.
  275.                      (when arg-types
  276.                        (do ((fl forms (cdr fl))
  277.                             (fl1 nil)
  278.                             (al args (cdr al)))
  279.                            ((endp fl)
  280.                             (setq forms (reverse fl1)))
  281.                            (cond ((endp arg-types) (push (car fl) fl1))
  282.                                  (t (push (and-form-type (car arg-types)
  283.                                                          (car fl)
  284.                                                          (car al))
  285.                                           fl1)
  286.                                     (pop arg-types))))))
  287.                 (let ((arg-types (get fname 'arg-types)))
  288.                      ;;; Check argument types.
  289.                      (when arg-types
  290.                            (do ((fl forms (cdr fl))
  291.                                 (al args (cdr al)))
  292.                                ((or (endp arg-types) (endp fl)))
  293.                                (check-form-type (car arg-types)
  294.                                                 (car fl) (car al))
  295.                                (pop arg-types))))
  296.                 (case fname
  297.                       (aref
  298.                        (let ((etype (info-type (cadar forms))))
  299.                             (when (or (and (eq etype 'string)
  300.                                            (setq etype 'character))
  301.                                       (and (consp etype)
  302.                                            (or (eq (car etype) 'array)
  303.                                                (eq (car etype) 'vector))
  304.                                            (setq etype (cadr etype))))
  305.                                   (setq etype
  306.                                         (type-and (info-type info) etype))
  307.                                   (when (null etype)
  308.                                         (cmpwarn
  309.                                          "Type mismatch was found in ~s."
  310.                                          (cons fname args)))
  311.                                   (setf (info-type info) etype))))
  312.                       (si:aset
  313.                        (let ((etype (info-type (cadar forms))))
  314.                             (when (or (and (eq etype 'string)
  315.                                            (setq etype 'character))
  316.                                       (and (consp etype)
  317.                                            (or (eq (car etype) 'array)
  318.                                                (eq (car etype) 'vector))
  319.                                            (setq etype (cadr etype))))
  320.                                   (setq etype
  321.                                         (type-and (info-type info)
  322.                                           (type-and (info-type
  323.                                                      (cadar (last forms)))
  324.                                                     etype)))
  325.                                   (when (null etype)
  326.                                         (cmpwarn
  327.                                          "Type mismatch was found in ~s."
  328.                                          (cons fname args)))
  329.                                   (setf (info-type info) etype)
  330.                                   (setf (info-type (cadar (last forms)))
  331.                                         etype)
  332.                                   ))))
  333.         ;; some functions can have result type deduced from
  334.         ;; arg types.
  335.         
  336.         (let ((tem (result-type-from-args fname
  337.                           (mapcar #'(lambda (x) (info-type (cadr x)))
  338.                               forms))))
  339.               (when tem
  340.                 (setq tem (type-and tem (info-type info)))
  341.                 (setf (info-type info) tem)))
  342.         (list 'call-global info fname forms)))
  343.         )
  344.   )
  345.  
  346. ;;numbers and character constants may be sometimes used, instead
  347. ;;of the variable, eg inside eql
  348.  
  349. (defun replace-constant (lis &aux found tem)
  350.   (do ((v lis (cdr v)))
  351.       ((null v)  found)
  352.       (cond ((and (constantp (car v))
  353.           (or (numberp (setq tem(eval (car v))))
  354.               (characterp tem)))
  355.          (setq found t) (setf (car v) tem)))))
  356.  
  357.  
  358.  
  359. (defun c1lambda-fun (lambda-expr args &aux (info (make-info :sp-change t)))
  360.   (setq args (c1args args info))
  361.   (setq lambda-expr (c1lambda-expr lambda-expr))
  362.   (add-info info (cadr lambda-expr))
  363.   (list 'call-lambda info lambda-expr args)
  364.   )
  365.  
  366. (defun c2expr (form)
  367.   (if (eq (car form) 'call-global)
  368.       (c2call-global (caddr form) (cadddr form) nil  (info-type (cadr form)))
  369.       (if (or (eq (car form) 'let)
  370.                  (eq (car form) 'let*))
  371.              (let ((*volatile* (volatile (cadr form))))
  372.                    (declare (special *volatile*))
  373.                    (apply (get (car form) 'c2) (cddr form)))
  374.     (let ((tem (get (car form) 'c2)))
  375.       (cond (tem (apply tem (cddr form)))
  376.         ((setq tem (get (car form) 'wholec2))
  377.          (funcall tem form))
  378.         (t (baboon)))))))
  379.  
  380. (defun c2funcall-sfun (fn args info &aux  locs (all (cons fn args))) info
  381.   (let ((*inline-blocks* 0))
  382.     (setq locs (get-inline-loc
  383.         (list (make-list (length all) :initial-element t)
  384.               t #.(flags ans set) 'fcalln-inline) all))
  385.     (unwind-exit locs)
  386.     (close-inline-blocks)))
  387.  
  388. (defun c2expr* (form)
  389.   (let* ((*exit* (next-label))
  390.          (*unwind-exit* (cons *exit* *unwind-exit*)))
  391.         (c2expr form)
  392.         (wt-label *exit*))
  393.   )
  394.  
  395. (defun c2expr-top (form top &aux (*vs* 0) (*max-vs* 0) (*level* (1+ *level*))
  396.                                  (*reservation-cmacro* (next-cmacro)))
  397.   (wt-nl "{register object *base" (1- *level*) "=base;")
  398.   (base-used)
  399.   (wt-nl "{register object *base=V" top ";")
  400.   (wt-nl "register object *sup=vs_base+VM" *reservation-cmacro* ";")
  401.   (if *safe-compile*
  402.       (wt-nl "vs_reserve(VM" *reservation-cmacro* ");")
  403.       (wt-nl "vs_check;"))
  404.   (wt-nl) (reset-top)
  405.   (c2expr form)
  406.   (push (cons *reservation-cmacro* *max-vs*) *reservations*)
  407.   (wt-nl "}}")
  408.   )
  409.  
  410. (defun c2expr-top* (form top)
  411.   (let* ((*exit* (next-label))
  412.          (*unwind-exit* (cons *exit* *unwind-exit*)))
  413.         (c2expr-top form top)
  414.         (wt-label *exit*)))
  415.  
  416. (defun c1progn (forms &aux (fl nil))
  417.   (cond ((endp forms) (c1nil))
  418.         ((endp (cdr forms)) (c1expr (car forms)))
  419.         (t (let ((info (make-info)))
  420.                 (dolist (form forms)
  421.                         (setq form (c1expr form))
  422.                         (push form fl)
  423.                         (add-info info (cadr form)))
  424.                 (setf (info-type info) (info-type (cadar fl)))
  425.                 (list 'progn info (reverse fl))
  426.                 )))
  427.   )
  428.  
  429. ;;; Should be deleted.
  430. (defun c1progn* (forms info)
  431.   (setq forms (c1progn forms))
  432.   (add-info info (cadr forms))
  433.   forms)
  434.  
  435. (defun c2progn (forms)
  436.   ;;; The length of forms may not be less than 1.
  437.   (do ((l forms (cdr l)))
  438.       ((endp (cdr l))
  439.        (c2expr (car l)))
  440.       (declare (object l))
  441.       (let* ((*value-to-go* 'trash)
  442.              (*exit* (next-label))
  443.              (*unwind-exit* (cons *exit* *unwind-exit*)))
  444.             (c2expr (car l))
  445.             (wt-label *exit*)
  446.             ))
  447.   )
  448.  
  449. (defun c1args (forms info)
  450.   (mapcar #'(lambda (form) (c1expr* form info)) forms))
  451.  
  452. ;;; Structures
  453.  
  454. (defun c1structure-ref (args)
  455.   (if (and (not *safe-compile*)
  456.        (not (endp args))
  457.            (not (endp (cdr args)))
  458.            (consp (cadr args))
  459.            (eq (caadr args) 'quote)
  460.            (not (endp (cdadr args)))
  461.            (symbolp (cadadr args))
  462.            (endp (cddadr args))
  463.            (not (endp (cddr args)))
  464.            (si:fixnump (caddr args))
  465.            (endp (cdddr args)))
  466.       (c1structure-ref1 (car args)  (cadadr args) (caddr args))
  467.       (let ((info (make-info)))
  468.         (list 'call-global info 'si:structure-ref (c1args args info)))))
  469.  
  470. (defun c1structure-ref1 (form name index &aux (info (make-info)))
  471.   ;;; Explicitly called from c1expr and c1structure-ref.
  472.   (declare (special  *aet-types*))
  473.   (cond (*safe-compile* (c1expr `(si::structure-ref ,form ',name ,index)))
  474.     (t
  475.   (let* ((sd (get name 'si::s-data))
  476.      (aet-type (aref (si::s-data-raw sd) index))
  477.      )
  478.     (setf (info-type info) (type-filter (aref *aet-types* aet-type)))
  479.     (list 'structure-ref info
  480.       (c1expr* form info)
  481.       (add-symbol name)
  482.       index sd)
  483.     
  484.     ))))
  485.  
  486. (defun coerce-loc-structure-ref (arg type-wanted &aux (form (cdr arg)))
  487.   (let* ((sd (fourth form))
  488.      (index (caddr form)))
  489.     (cond (sd
  490.         (let* ((aet-type (aref (si::s-data-raw sd) index))
  491.            (type (aref *aet-types* aet-type)))
  492.           (cond ((eq (inline-type (type-filter type)) 'inline)
  493.              (or (eql aet-type 0) (error "bad type ~a" type))))
  494.           (setf (info-type (car arg)) (type-filter type))
  495.           (coerce-loc
  496.               (list (inline-type
  497.                  (type-filter type))
  498.                    (flags)
  499.                 'my-call
  500.                 (list
  501.                  (car
  502.                   (inline-args (list (car form))
  503.                        '(t)))
  504.                  'joe index sd))
  505.               (type-filter type-wanted)))
  506.         )
  507.       (t (wfs-error)))))
  508.  
  509.  
  510. (defun c2structure-ref (form name-vv index sd
  511.                              &aux (*vs* *vs*) (*inline-blocks* 0))
  512.   (let ((loc (car (inline-args (list form) '(t))))
  513.     (type (aref *aet-types* (aref (si::s-data-raw sd) index))))
  514.        (unwind-exit
  515.      (list (inline-type (type-filter type))
  516.               (flags) 'my-call
  517.               (list  loc  name-vv
  518.                  index sd))))
  519.   (close-inline-blocks)
  520.   )
  521.  
  522.  
  523. (defun my-call (loc name-vv ind sd) name-vv
  524.   (let* ((raw (si::s-data-raw sd))
  525.      (spos (si::s-data-slot-position sd)))
  526.     (if *safe-compile* (wfs-error)
  527.       (wt "STREF("  (aet-c-type (aref *aet-types* (aref raw ind)) )
  528.       "," loc "," (aref spos ind) ")"))))
  529.  
  530.  
  531. (defun c1structure-set (args &aux (info (make-info)))
  532.   (if (and (not (endp args)) (not *safe-compile*)
  533.            (not (endp (cdr args)))
  534.            (consp (cadr args))
  535.            (eq (caadr args) 'quote)
  536.            (not (endp (cdadr args)))
  537.            (symbolp (cadadr args))
  538.            (endp (cddadr args))
  539.            (not (endp (cddr args)))
  540.            (si:fixnump (caddr args))
  541.            (not (endp (cdddr args)))
  542.            (endp (cddddr args)))
  543.       (let ((x (c1expr (car args)))
  544.             (y (c1expr (cadddr args))))
  545.         (add-info info (cadr x))
  546.         (add-info info (cadr y))
  547.         (setf (info-type info) (info-type (cadr y)))
  548.         (list 'structure-set info x
  549.               (add-symbol (cadadr args)) ;;; remove QUOTE.
  550.               (caddr args) y (get (cadadr args) 'si::s-data)))
  551.       (list 'call-global info 'si:structure-set (c1args args info))))
  552.  
  553.  
  554. ;; The following (side-effects) exists for putting at the end of an
  555. ;; argument list to force all previous arguments to be stored in
  556. ;; variables, when computing inline-args.
  557.  
  558.  
  559. (push '(() t #.(flags ans set) "Ct")  (get 'side-effects  'inline-always))
  560.  
  561. (defun c2structure-set (x name-vv ind y sd 
  562.                           &aux locs (*vs* *vs*) (*inline-blocks* 0))
  563.   name-vv
  564.   (let* ((raw (si::s-data-raw sd))
  565.   (type (aref *aet-types* (aref raw ind)))
  566.   (spos (si::s-data-slot-position sd))
  567.   (tftype (type-filter type))
  568.   ix iy)
  569.  
  570.    (setq locs (inline-args
  571.         (list x y (list 'call-global (make-info) 'side-effects nil))
  572.         (if (eq type t) '(t t t)
  573.    `(t ,tftype t))))
  574.   
  575.   (setq ix (car locs))
  576.   (setq iy (cadr locs))
  577.   (if *safe-compile* (wfs-error))
  578.   (wt-nl "STSET(" (aet-c-type type )","
  579.     ix "," (aref spos ind) ", " iy ");")
  580.   (unwind-exit (list (inline-type tftype) (flags) 'wt-loc (list iy)))
  581.   (close-inline-blocks)
  582.   ))
  583.  
  584. (defun c1constant-value (val always-p)
  585.   (cond
  586.    ((eq val nil) (c1nil))
  587.    ((eq val t) (c1t))
  588.    ((si:fixnump val)
  589.     (list 'LOCATION (make-info :type 'fixnum)
  590.           (list 'FIXNUM-VALUE (and (>= (abs val) 1024)(add-object val))
  591.         val)))
  592.    ((characterp val)
  593.     (list 'LOCATION (make-info :type 'character)
  594.           (list 'CHARACTER-VALUE (add-object val) (char-code val))))
  595.    ((typep val 'long-float)
  596.     ;; We can't read in long-floats which are too big:
  597.     (let (tem x)
  598.       (unless (setq tem (cadr (assoc val *objects*)))
  599.          (cond((or
  600.          (and
  601.            (> (setq x (abs val)) (/ most-positive-long-float 2))
  602.            (c1expr `(si::|#,| * ,(/ val most-positive-long-float)
  603.                  most-positive-long-float)))
  604.          (and
  605.            (< x (* least-positive-long-float 1.0d20))
  606.            (c1expr `(si::|#,| * ,(/ val least-positive-long-float)
  607.                  least-positive-long-float))))
  608.            (push (list val (setq tem *next-vv*)) *objects*))))
  609.       (list 'LOCATION (make-info :type 'long-float)
  610.         (list 'LONG-FLOAT-VALUE (or tem (add-object val)) val))))
  611.    ((typep val 'short-float)
  612.     (list 'LOCATION (make-info :type 'short-float)
  613.           (list 'SHORT-FLOAT-VALUE (add-object val) val)))
  614.    (always-p
  615.     (list 'LOCATION (make-info :type (object-type val))
  616.           (list 'VV (add-object val))))
  617.    (t nil)))
  618.  
  619. (defmacro si::define-compiler-macro (name vl &rest body)
  620.   `(progn (si:putprop ',name
  621.                       (caddr (si:defmacro* ',name ',vl ',body))
  622.                       'compiler-macro)
  623.           ',name))  
  624.  
  625. (defun si::undef-compiler-macro (name)
  626.   (remprop name 'compiler-macro))
  627.  
  628. (defvar *compiler-temps*
  629.         '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9))
  630.  
  631. (defmacro si:define-inline-function (name vars &body body)
  632.   (let ((temps nil)
  633.         (*compiler-temps* *compiler-temps*))
  634.     (dolist (var vars)
  635.       (if (and (symbolp var)
  636.                (not (si:memq var '(&optional &rest &key &aux))))
  637.           (push (or (pop *compiler-temps*)
  638.                     (gentemp "TMP" (find-package 'compiler)))
  639.                 temps)
  640.           (error "The parameter ~s for the inline function ~s is illegal."
  641.                  var name)))
  642.     (let ((binding (cons 'list (mapcar
  643.                                 #'(lambda (var temp) `(list ',var ,temp))
  644.                                 vars temps))))
  645.       `(progn
  646.          (defun ,name ,vars ,@body)
  647.          (si:define-compiler-macro ,name ,temps
  648.            (list* 'let ,binding ',body))))))
  649.  
  650. (defun name-to-sd (x &aux sd)
  651.   (or (and (symbolp x) (setq sd (get x 'si::s-data)))
  652.       (error "The structure ~a is undefined." x))
  653.   sd)
  654.  
  655. ;; lay down code for a load time eval constant.
  656. (defun name-sd1 (x)
  657.   (or  (get x 'name-to-sd)
  658.       (setf (get x 'name-sd)
  659.         `(si::|#,| name-to-sd ',x))))
  660.  
  661. (defun co1structure-predicate (f args &aux tem)
  662.   (cond ((and (symbolp f)
  663.           (setq tem (get f 'si::struct-predicate)))
  664.      (c1expr `(typep ,(car args) ',tem)))))
  665.  
  666.  
  667.