Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[e90b2f]: src / new-cmp / cmpc-set.lsp Maximize Restore History

Download this file

cmpc-set.lsp    117 lines (103 with data), 3.8 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll.
;;;;
;;;; This program 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 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;; CMPC-SET Set locations
(in-package "C-BACKEND")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ASSIGNING TO LOCATIONS
;;;
(defun uses-values (loc)
(and (consp loc)
(or (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT) :test #'eq)
(and (eq (car loc) 'C-INLINE)
(eq (sixth loc) 'VALUES)))))
(defun set-loc (loc destination)
(unless (eql destination loc)
(cond ((var-p destination)
(set-var loc destination))
((atom destination)
(let ((fd (gethash destination +c2-set-loc-table+)))
(cond (fd
(funcall fd loc))
((setq fd (gethash destination +c2-wt-loc-table+))
(wt-nl) (funcall fd) (wt "= ")
(wt-coerce-loc (loc-representation-type destination) loc)
(wt ";"))
(t
(error "No known way to assign to location ~A"
destination)))))
(t
(let* ((name (first destination))
(fd (gethash name +c2-set-loc-table+)))
(cond (fd
(apply fd loc (rest destination)))
((setq fd (gethash name +c2-wt-loc-table+))
(wt-nl) (apply fd (rest destination)) (wt "= ")
(wt-coerce-loc (loc-representation-type destination) loc)
(wt ";"))
(t
(error "No known way to assign to location ~A"
destination))))))))
(defun set-values-loc (loc)
(cond ((eq loc 'VALUES))
((uses-values loc)
(wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) (wt ";"))
(t
(wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc)
(wt ";")
(wt-nl "cl_env_copy->nvalues=1;"))))
(defun set-values+value0-loc (loc)
(cond ((eq loc 'VALUES)
(wt-nl "value0=cl_env_copy->values[0];"))
((uses-values loc)
(wt-nl "value0=")(wt-coerce-loc :object loc) (wt ";"))
(t
(wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")
(wt-nl "cl_env_copy->nvalues=1;"))))
(defun set-value0-loc (loc)
(wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";"))
(defun set-return-loc (loc)
(set-values+value0-loc loc))
(defun set-actual-return-loc (loc)
(set-loc loc 'VALUES+VALUE0)
(wt-nl "return value0;"))
(defun set-trash-loc (loc)
(when (loc-has-side-effects loc)
(wt-nl loc ";")))
(defun set-the-loc (value type loc)
(set-loc value loc))
(defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb
(unless (var-p var)
(baboon))
(when (unused-variable-p var)
(set-loc loc 'trash)
(return-from set-var))
(case (var-kind var)
(DISCARDED
(set-loc loc 'TRASH))
(CLOSURE
(wt-nl)(wt-env var-loc)(wt "= ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
(LEXICAL
(wt-nl)(wt-lex var-loc)(wt "= ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
((SPECIAL GLOBAL)
(if (safe-compile)
(wt-nl "cl_set(" var-loc ",")
(wt-nl "ECL_SETQ(cl_env_copy," var-loc ","))
(wt-coerce-loc (var-rep-type var) loc)
(wt ");"))
(t
(wt-nl var-loc "= ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))))