;;; CMPLOC  Set-loc and Wt-loc.
;;;
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

;; This file is part of GNU Common Lisp, herein referred to as GCL
;;
;; GCL is free software; you can redistribute it and/or modify it under
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; GCL is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
;; License for more details.
;; 
;; You should have received a copy of the GNU Library General Public License 
;; along with GCL; see the file COPYING.  If not, write to the Free Software
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.


(in-package 'compiler)

(defvar *value-to-go*)

;;; Valid locations are:
;;;	NIL
;;;	T
;;;	'FUN-VAL'
;;;	( 'VS' vs-address )
;;;	( 'VS*' vs-address )
;;;	( 'CCB-VS' ccb-vs )
;;;	( 'VAR' var-object ccb )
;;;	( 'VV' vv-index )
;;;	( 'CVAR' cvar )
;;;	( 'INLINE' side-effect-p fun/string locs )
;;;	( 'INLINE-COND' side-effect-p fun/string locs )
;;;	( 'INLINE-FIXNUM' side-effect-p fun/string locs )
;;;	( 'INLINE-CHARACTER' side-effect-p fun/string locs )
;;;	( 'INLINE-LONG-FLOAT' side-effect-p fun/string locs )
;;;	( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs )
;;;	( 'SIMPLE-CALL {   SYMLISPCALL-NO-EVENT
;;;   	                 | LISPCALL-NO-EVENT
;;;   	                 | SYMLISPCALL
;;;   	                 | LISPCALL }
;;;		vs-index number-of-arguments [ vv-index ] )
;;;	( 'VS-BASE' offset )
;;;	( 'CAR' cvar )
;;;	( 'CADR' cvar )
;;;	( 'SYMBOL-FUNCTION' vv-index )
;;;	( 'MAKE-CCLOSURE' cfun cllink )
;;;	( 'FIXNUM-VALUE' vv-index fixnum-value )
;;;	( 'FIXNUM-LOC' loc )
;;;	( 'CHARACTER-VALUE' vv-index character-code )
;;;	( 'CHARACTER-LOC' loc )
;;;	( 'LONG-FLOAT-VALUE' vv-index long-float-value )
;;;	( 'LONG-FLOAT-LOC' loc )
;;;	( 'SHORT-FLOAT-VALUE' vv-index short-float-value )
;;;	( 'SHORT-FLOAT-LOC' loc )


;;; Valid *value-to-go* locations are:
;;;
;;;	'RETURN'	The value is returned from the current function.
;;;	'RETURN-FIXNUM'
;;;	'RETURN-CHARACTER'
;;;	'RETURN-LONG-FLOAT'
;;;	'RETURN-SHORT-FLOAT'
;;;	'RETURN-OBJECT
;;;	'TRASH'		The value may be thrown away.
;;;	'TOP'		The value should be set at the top of vs as if it were
;;;			a resulted value of a function call.
;;;	( 'VS' vs-address )
;;;	( 'VS*' vs-address )
;;;	( 'CCB-VS' ccb-vs )
;;;	( 'VAR' var-object ccb )
;;;	( 'JUMP-TRUE' label )
;;;	( 'JUMP-FALSE' label )
;;;	( 'BDS-BIND' vv-index )
;;;	( 'PUSH-CATCH-FRAME' )
;;;	( 'DBIND' symbol-name-vv )

(si:putprop 'cvar 'wt-cvar 'wt-loc)
(si:putprop 'vv 'wt-vv 'wt-loc)
(si:putprop 'car 'wt-car 'wt-loc)
(si:putprop 'cdr 'wt-cdr 'wt-loc)
(si:putprop 'cadr 'wt-cadr 'wt-loc)
(si:putprop 'vs-base 'wt-vs-base 'wt-loc)
(si:putprop 'fixnum-value 'wt-fixnum-value 'wt-loc)
(si:putprop 'fixnum-loc 'wt-fixnum-loc 'wt-loc)
(si:putprop 'integer-loc 'wt-integer-loc 'wt-loc)
(si:putprop 'character-value 'wt-character-value 'wt-loc)
(si:putprop 'character-loc 'wt-character-loc 'wt-loc)
(si:putprop 'long-float-value 'wt-long-float-value 'wt-loc)
(si:putprop 'long-float-loc 'wt-long-float-loc 'wt-loc)
(si:putprop 'short-float-value 'wt-short-float-value 'wt-loc)
(si:putprop 'short-float-loc 'wt-short-float-loc 'wt-loc)
(si::putprop 'next-var-arg  'wt-next-var-arg 'wt-loc)

(defun wt-next-var-arg ()
  (wt "va_arg(ap,object)"))

(defun set-loc (loc &aux fd)
  (cond ((eq *value-to-go* 'return) (set-return loc))
        ((eq *value-to-go* 'trash)
         (cond ((and (consp loc)
                     (member (car loc)
                             '(INLINE INLINE-COND INLINE-FIXNUM inline-integer
                               INLINE-CHARACTER INLINE-LONG-FLOAT
                               INLINE-SHORT-FLOAT))
                     (cadr loc))
                (wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc))
                (wt ");"))
               ((and (consp loc) (eq (car loc) 'SIMPLE-CALL))
                (wt-nl "(void)" loc ";"))))
        ((eq *value-to-go* 'top)
         (unless (eq loc 'fun-val) (set-top loc)))
        ((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc))
        ((eq *value-to-go* 'return-character) (set-return-character loc))
        ((eq *value-to-go* 'return-long-float) (set-return-long-float loc))
        ((eq *value-to-go* 'return-short-float) (set-return-short-float loc))
        ((or (not (consp *value-to-go*))
             (not (symbolp (car *value-to-go*))))
         (baboon))
        ((setq fd (get (car *value-to-go*) 'set-loc))
         (apply fd loc (cdr *value-to-go*)))
        ((setq fd (get (car *value-to-go*) 'wt-loc))
         (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";"))
        (t (baboon)))
  )

(defun wt-loc (loc)
  (cond ((eq loc nil) (wt "Cnil"))
        ((eq loc t) (wt "Ct"))
        ((eq loc 'fun-val) (wt "vs_base[0]"))
        ((or (not (consp loc))
             (not (symbolp (car loc))))
         (baboon))
        (t (let ((fd (get (car loc) 'wt-loc)))
                (when (null fd) (baboon))
                (apply fd (cdr loc)))))
  )

(defun set-return (loc)
  (cond ((eq loc 'fun-val))
        ((and (consp loc) (eq (car loc) 'vs) (= (caadr loc) *level*))
         (wt-nl "vs_top=(vs_base=base+" (cdadr loc) ")+1;")
         (base-used))
        ((and (consp loc)
              (eq (car loc) 'var)
              (eq (var-kind (cadr loc)) 'LEXICAL)
              (not (var-ref-ccb (cadr loc)))
              (eql (car (var-ref (cadr loc))) *level*))
         (wt-nl "vs_top=(vs_base=base+" (cdr (var-ref (cadr loc))) ")+1;")
         (base-used))
        (t (set-top loc)))
  )

(defun set-top (loc)
 (let ((*vs* *vs*))
      (wt-nl) (wt-vs (vs-push)) (wt "= " loc ";")
      (wt-nl "vs_top=(vs_base=base+" (1- *vs*) ")+1;")
      (base-used)))

(defun wt-vs-base (offset) (wt "vs_base[" offset "]"))

(defun wt-car (cvar) (wt "(V" cvar "->c.c_car)"))

(defun wt-cdr (cvar) (wt "(V" cvar "->c.c_cdr)"))

(defun wt-cadr (cvar) (wt "(V" cvar "->c.c_cdr->c.c_car)"))

(defun wt-cvar (cvar &optional type)
  (if type (wt "/* " (symbol-name type) " */"))
  (wt "V" cvar))

(defun wt-vv (vv) (wt "VV[" vv "]"))

(defun wt-fixnum-loc (loc)
  (cond ((and (consp loc)
              (eq (car loc) 'var)
              (eq (var-kind (cadr loc)) 'FIXNUM))
         (wt "V" (var-loc (cadr loc))))
        ((and (consp loc) (eq (car loc) 'INLINE-FIXNUM))
         (wt-inline-loc (caddr loc) (cadddr loc)))
        ((and (consp loc) (eq (car loc) 'fixnum-value))
         (wt (caddr loc)))
        ((and (consp loc) (member (car loc) '(INLINE-SHORT-FLOAT
					      INLINE-LONG-FLOAT)))
	 (wt "((int)(")
	 (wt-inline-loc  (caddr loc) (cadddr loc))
	 (wt "))"))
        (t (wt "fix(" loc ")"))))

(defun wt-integer-loc (loc &optional type
			   &aux (avma t)(first (and (consp loc) (car loc))))
  (case first
    (inline-fixnum
     (wt "stoi(")
     (wt-inline-loc (caddr loc) (cadddr loc))
     (wt ")"))
    (INLINE-INTEGER (setq avma nil)  (wt-inline-loc (caddr loc) (cadddr loc)))
    (fixnum-value       (wt "stoi(" (caddr loc) ")"))
    (var
     (case (var-kind (cadr loc))
       (integer  (setq avma nil)   (wt "V" (var-loc (cadr loc))))
       (fixnum           (wt "stoi(V" (var-loc (cadr loc))")"))
       (otherwise (wt "otoi(" loc ")"))))
    (otherwise (wt "otoi(" loc ")")))
  (and avma (not *restore-avma*)(wfs-error))
  )
     

(defun fixnum-loc-p (loc)
  (and (consp loc)
       (or (and (eq (car loc) 'var)
                (eq (var-kind (cadr loc)) 'FIXNUM))
           (eq (car loc) 'INLINE-FIXNUM)
           (eq (car loc) 'fixnum-value))))

(defun wt-fixnum-value (vv fixnum-value)
  (if vv (wt "VV[" vv "]")
    (wt "small_fixnum(" fixnum-value ")")))
        

(defun wt-character-loc (loc)
  (cond ((and (consp loc)
              (eq (car loc) 'var)
              (eq (var-kind (cadr loc)) 'CHARACTER))
         (wt "V" (var-loc (cadr loc))))
        ((and (consp loc) (eq (car loc) 'INLINE-CHARACTER))
         (wt-inline-loc (caddr loc) (cadddr loc)))
        ((and (consp loc) (eq (car loc) 'CHARACTER-VALUE))
         (wt (caddr loc)))
        (t (wt "char_code(" loc ")"))))

(defun character-loc-p (loc)
  (and (consp loc)
       (or (and (eq (car loc) 'var)
                (eq (var-kind (cadr loc)) 'CHARACTER))
           (eq (car loc) 'INLINE-CHARACTER)
           (eq (car loc) 'character-value))))

(defun wt-character-value (vv character-code)
       (declare (ignore character-code))
       (wt "VV[" vv "]"))

(defun wt-long-float-loc (loc)
  (cond ((and (consp loc)
              (eq (car loc) 'var)
              (eq (var-kind (cadr loc)) 'LONG-FLOAT))
         (wt "V" (var-loc (cadr loc))))
        ((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT))
         (wt-inline-loc (caddr loc) (cadddr loc)))
        ((and (consp loc) (eq (car loc) 'long-float-value))
         (wt (caddr loc)))
        (t (wt "lf(" loc ")"))))

(defun long-float-loc-p (loc)
  (and (consp loc)
       (or (and (eq (car loc) 'var)
                (eq (var-kind (cadr loc)) 'LONG-FLOAT))
           (eq (car loc) 'INLINE-LONG-FLOAT)
           (eq (car loc) 'long-float-value))))

(defun wt-long-float-value (vv long-float-value)
       (declare (ignore long-float-value))
       (wt "VV[" vv "]"))

(defun wt-short-float-loc (loc)
  (cond ((and (consp loc)
              (eq (car loc) 'var)
              (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
         (wt "V" (var-loc (cadr loc))))
        ((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT))
         (wt-inline-loc (caddr loc) (cadddr loc)))
        ((and (consp loc) (eq (car loc) 'short-float-value))
         (wt (caddr loc)))
        (t (wt "sf(" loc ")"))))

(defun short-float-loc-p (loc)
  (and (consp loc)
       (or (and (eq (car loc) 'var)
                (eq (var-kind (cadr loc)) 'SHORT-FLOAT))
           (eq (car loc) 'INLINE-SHORT-FLOAT)
           (eq (car loc) 'short-float-value))))

(defun wt-short-float-value (vv short-float-value)
       (declare (ignore short-float-value))
       (wt "VV[" vv "]"))