mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 07:12:26 -08:00
319 lines
11 KiB
Common Lisp
319 lines
11 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
|
;;;; Copyright (c) 1990, Giuseppe Attardi.
|
|
;;;;
|
|
;;;; 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.
|
|
|
|
;;;; CMPMULT Multiple-value-call and Multiple-value-prog1.
|
|
|
|
(in-package "COMPILER")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(progn
|
|
(defun c1multiple-value-call (args &aux forms)
|
|
(check-args-number 'MULTIPLE-VALUE-CALL args 1)
|
|
(cond
|
|
;; (M-V-C #'FUNCTION) => (FUNCALL #'FUNCTION)
|
|
((endp (rest args))
|
|
(c1funcall args))
|
|
;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z)
|
|
((and (= (length args) 2)
|
|
(consp (setq forms (second args)))
|
|
(eq 'VALUES (first forms)))
|
|
(c1funcall (list* (first args) (rest forms))))
|
|
;; More complicated case.
|
|
(t
|
|
(let ((function (gensym))
|
|
(frame (gensym)))
|
|
`(with-stack ,frame
|
|
(let* ((,function ,(first args)))
|
|
,@(loop for i in (rest args)
|
|
collect `(stack-push-values ,frame ,i))
|
|
(si::apply-from-stack-frame ,frame ,function)))))))
|
|
|
|
(defun c1multiple-value-prog1 (args)
|
|
(check-args-number 'MULTIPLE-VALUE-PROG1 args 1)
|
|
(let ((frame (gensym)))
|
|
`(with-stack ,frame
|
|
(stack-push-values ,frame ,(first args))
|
|
,@(rest args)
|
|
(stack-pop ,frame))))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; Beppe:
|
|
;;; this is the WRONG way to handle 1 value problem.
|
|
;;; should be done in c2values, so that (values (truncate a b)) can
|
|
;;; be used to restrict to one value, so we would not have to warn
|
|
;;; if this occurred in a proclaimed fun.
|
|
|
|
(defun c1values (args)
|
|
(make-c1form* 'VALUES :args (c1args* args)))
|
|
|
|
(defun c2values (c1form forms)
|
|
(declare (ignore c1form))
|
|
(when (and (eq *destination* 'RETURN-OBJECT)
|
|
(rest forms)
|
|
(consp *current-form*)
|
|
(eq 'DEFUN (first *current-form*)))
|
|
(cmpwarn "Trying to return multiple values. ~
|
|
~%;But ~a was proclaimed to have single value.~
|
|
~%;Only first one will be assured."
|
|
(second *current-form*)))
|
|
(cond
|
|
;; When the values are not going to be used, then just
|
|
;; process each form separately.
|
|
((eq *destination* 'TRASH)
|
|
(mapc #'c2expr* forms)
|
|
;; We really pass no value, but we need UNWIND-EXIT to trigger all the
|
|
;; frame-pop, stack-pop and all other exit forms.
|
|
(unwind-exit 'VALUE0)
|
|
)
|
|
;; For (VALUES) we can replace the output with either NIL (if the value
|
|
;; is actually used) and set only NVALUES when the value is the output
|
|
;; of a function.
|
|
((endp forms)
|
|
(cond ((eq *destination* 'RETURN)
|
|
(wt-nl "value0 = ECL_NIL;")
|
|
(wt-nl "cl_env_copy->nvalues = 0;")
|
|
(unwind-exit 'RETURN))
|
|
((eq *destination* 'VALUES)
|
|
(wt-nl "cl_env_copy->values[0] = ECL_NIL;")
|
|
(wt-nl "cl_env_copy->nvalues = 0;")
|
|
(unwind-exit 'VALUES))
|
|
(t
|
|
(unwind-exit 'NIL))))
|
|
;; For a single form, we must simply ensure that we only take a single
|
|
;; value of those that the function may output.
|
|
((endp (rest forms))
|
|
(let ((form (first forms)))
|
|
(if (or (not (member *destination* '(RETURN VALUES)))
|
|
(c1form-single-valued-p form))
|
|
(c2expr form)
|
|
(progn
|
|
(let ((*destination* 'VALUE0)) (c2expr* form))
|
|
(unwind-exit 'VALUE0)))))
|
|
;; In all other cases, we store the values in the VALUES vector,
|
|
;; and force the compiler to retrieve anything out of it.
|
|
(t
|
|
(let* ((nv (length forms))
|
|
(*inline-blocks* 0)
|
|
(*temp* *temp*)
|
|
(forms (nreverse (coerce-locs (inline-args forms)))))
|
|
;; By inlining arguments we make sure that VL has no call to funct.
|
|
;; Reverse args to avoid clobbering VALUES(0)
|
|
(wt-nl "cl_env_copy->nvalues = " nv ";")
|
|
(do ((vl forms (rest vl))
|
|
(i (1- (length forms)) (1- i)))
|
|
((null vl))
|
|
(declare (fixnum i))
|
|
(wt-nl "cl_env_copy->values[" i "] = " (first vl) ";"))
|
|
(unwind-exit 'VALUES)
|
|
(close-inline-blocks)))))
|
|
|
|
(defun c1multiple-value-setq (args &aux (vars nil) (temp-vars nil)
|
|
(late-bindings nil))
|
|
(check-args-number 'MULTIPLE-VALUE-SETQ args 2 2)
|
|
(dolist (var (reverse (first args)))
|
|
(cmpck (not (symbolp var)) "The variable ~s is not a symbol." var)
|
|
(let* ((var-or-form (chk-symbol-macrolet var))
|
|
(type t))
|
|
(unless (when (symbolp var-or-form)
|
|
(cmpck (constantp var-or-form)
|
|
"The constant ~s is being assigned a value." var-or-form)
|
|
(when (or (not (policy-type-assertions))
|
|
(trivial-type-p
|
|
(setf type (variable-type-in-env var-or-form))))
|
|
(push var-or-form vars)
|
|
t))
|
|
(let ((new-var (gensym)))
|
|
(push new-var vars)
|
|
(push new-var temp-vars)
|
|
(push `(setf ,var-or-form (checked-value ,type ,new-var)) late-bindings)))))
|
|
(let ((value (second args)))
|
|
(cond (temp-vars
|
|
`(let* (,@temp-vars)
|
|
(multiple-value-setq ,vars ,value)
|
|
,@late-bindings))
|
|
((endp vars)
|
|
`(values ,value))
|
|
((= (length vars) 1)
|
|
`(setq ,(first vars) ,value))
|
|
(t
|
|
(setq value (c1expr value)
|
|
vars (mapcar #'c1vref vars))
|
|
(add-to-set-nodes-of-var-list
|
|
vars (make-c1form* 'MULTIPLE-VALUE-SETQ :args vars value))))))
|
|
|
|
(defun bind-or-set (loc v use-bind)
|
|
(cond ((not use-bind)
|
|
(set-var loc v))
|
|
((or (plusp (var-ref v))
|
|
(member (var-kind v) '(SPECIAL GLOBAL)))
|
|
(bind loc v))))
|
|
|
|
(defun values-loc-or-value0 (i)
|
|
(if (plusp i) (values-loc i) 'VALUE0))
|
|
|
|
(defun do-m-v-setq-fixed (nvalues vars form use-bind)
|
|
;; This routine should evaluate FORM and store the values (whose amount
|
|
;; is known to be NVALUES) into the variables VARS. The output is a
|
|
;; place from where the first value can be retreived.
|
|
;; INV: There is at least one variable.
|
|
;;
|
|
(if (or (> nvalues 1) use-bind)
|
|
(let ((*destination* 'RETURN))
|
|
(c2expr* form)
|
|
(loop for i from 0 below nvalues
|
|
for v in vars
|
|
for loc = (values-loc-or-value0 i)
|
|
do (bind-or-set loc v use-bind))
|
|
'VALUE0)
|
|
(let ((*destination* (first vars)))
|
|
(c2expr* form)
|
|
*destination*)))
|
|
|
|
(defun do-m-v-setq-any (min-values max-values vars use-bind)
|
|
;; This routine moves values from the multiple-value stack into the
|
|
;; variables VARS. The amount of values is not known (or at least we only
|
|
;; know that there is some number between MIN-VALUES and MAX-VALUES). If
|
|
;; the values are to be created with BIND, then USED-BIND=T. The output of
|
|
;; this routine is a location containing the first value (typically, the
|
|
;; name of the first variable).
|
|
;;
|
|
(let* ((*lcl* *lcl*)
|
|
(nr (make-lcl-var :type :int))
|
|
(output (first vars))
|
|
(labels '()))
|
|
;; We know that at least MIN-VALUES variables will get a value
|
|
(dotimes (i min-values)
|
|
(when vars
|
|
(let ((v (pop vars))
|
|
(loc (values-loc-or-value0 i)))
|
|
(bind-or-set loc v use-bind))))
|
|
;; If there are more variables, we have to check whether there
|
|
;; are enough values left in the stack.
|
|
(when vars
|
|
(wt-nl-open-brace) ;; Brace [1]
|
|
(wt-nl "int " nr " = cl_env_copy->nvalues-" min-values ";")
|
|
;;
|
|
;; Loop for assigning values to variables
|
|
;;
|
|
(do (;; We call BIND twice for each variable. Hence, we need to
|
|
;; remove spurious BDS-BIND from the list. See also C2LAMBDA.
|
|
(*unwind-exit* *unwind-exit*)
|
|
(vs vars (rest vs))
|
|
(i min-values (1+ i)))
|
|
((or (endp vs) (= i max-values)))
|
|
(declare (fixnum i))
|
|
(let ((loc (values-loc-or-value0 i))
|
|
(v (first vs))
|
|
(label (next-label)))
|
|
(wt-nl "if (" nr "--<=0) ") (wt-go label)
|
|
(push label labels)
|
|
(bind-or-set loc v use-bind)))
|
|
;;
|
|
;; Loop for setting default values when there are less output than vars.
|
|
;;
|
|
(let ((label (next-label)))
|
|
(wt-nl) (wt-go label)
|
|
(wt-nl-close-brace) ;; Matches [1]
|
|
(push label labels)
|
|
(setq labels (nreverse labels))
|
|
(dolist (v vars)
|
|
(when labels (wt-label (pop labels)))
|
|
(bind-or-set '(C-INLINE (:object) "ECL_NIL" () t nil) v use-bind))
|
|
(when labels (wt-label label))))
|
|
output))
|
|
|
|
(defun do-m-v-setq (vars form use-bind)
|
|
(multiple-value-bind (min-values max-values)
|
|
(c1form-values-number form)
|
|
(if (= min-values max-values)
|
|
(do-m-v-setq-fixed min-values vars form use-bind)
|
|
(let ((*destination* 'RETURN))
|
|
(c2expr* form)
|
|
(do-m-v-setq-any min-values max-values vars use-bind)))))
|
|
|
|
(defun c2multiple-value-setq (c1form vars form)
|
|
(declare (ignore c1form))
|
|
(unwind-exit (do-m-v-setq vars form nil)))
|
|
|
|
(defun c1multiple-value-bind (args)
|
|
(check-args-number 'MULTIPLE-VALUE-BIND args 2)
|
|
(let* ((*cmp-env* (cmp-env-copy))
|
|
(variables (pop args))
|
|
(init-form (pop args)))
|
|
(when (= (length variables) 1)
|
|
(return-from c1multiple-value-bind
|
|
`(let* ((,(first variables) ,init-form))
|
|
,@args)))
|
|
(multiple-value-bind (body ss ts is other-decls)
|
|
(c1body args nil)
|
|
(c1declare-specials ss)
|
|
(let* ((vars (loop for name in variables
|
|
collect (c1make-var name ss is ts))))
|
|
(setq init-form (c1expr init-form))
|
|
(mapc #'push-vars vars)
|
|
(check-vdecl variables ts is)
|
|
(setq body (c1decl-body other-decls body))
|
|
(mapc #'check-vref vars)
|
|
(make-c1form* 'MULTIPLE-VALUE-BIND :type (c1form-type body)
|
|
:local-vars vars
|
|
:args vars init-form body)))))
|
|
|
|
(defun c2multiple-value-bind (c1form vars init-form body)
|
|
(declare (ignore c1form))
|
|
(let* ((*unwind-exit* *unwind-exit*)
|
|
(*env-lvl* *env-lvl*)
|
|
(*env* *env*)
|
|
(*lcl* *lcl*)
|
|
(labels nil)
|
|
(env-grows nil)
|
|
(nr (make-lcl-var :type :int))
|
|
(*inline-blocks* 0)
|
|
min-values max-values)
|
|
;; 1) Retrieve the number of output values
|
|
(multiple-value-setq (min-values max-values)
|
|
(c1form-values-number init-form))
|
|
|
|
;; 2) For all variables which are not special and do not belong to
|
|
;; a closure, make a local C variable.
|
|
(dolist (var vars)
|
|
(declare (type var var))
|
|
(let ((kind (local var)))
|
|
(if kind
|
|
(when (or (plusp (var-ref var))
|
|
(member (var-kind var) '(SPECIAL GLOBAL)))
|
|
(maybe-open-inline-block)
|
|
(bind (next-lcl) var)
|
|
(wt-nl *volatile* (rep-type-name kind) " " var ";")
|
|
(wt-comment (var-name var)))
|
|
(unless env-grows (setq env-grows (var-ref-ccb var))))))
|
|
|
|
;; 3) If there are closure variables, set up an environment.
|
|
(when (setq env-grows (env-grows env-grows))
|
|
(let ((env-lvl *env-lvl*))
|
|
(maybe-open-inline-block)
|
|
(wt-nl "volatile cl_object env" (incf *env-lvl*)
|
|
" = env" env-lvl ";")))
|
|
|
|
;; 4) Assign the values to the variables, compiling the form
|
|
;; and binding the variables in the process.
|
|
(do-m-v-setq vars init-form t)
|
|
|
|
;; 5) Compile the body. If there are bindings of special variables,
|
|
;; these bindings are undone here.
|
|
(c2expr body)
|
|
|
|
;; 6) Close the C expression.
|
|
(close-inline-blocks)))
|
|
|