467 |
;;; check arguments |
;;; check arguments |
468 |
(when (or *safe-compile* *compiler-check-args*) |
(when (or *safe-compile* *compiler-check-args*) |
469 |
(cond ((or rest optionals) |
(cond ((or rest optionals) |
470 |
(when requireds |
(when requireds |
471 |
(wt-nl "if(vs_top-vs_base<" (length requireds) |
(wt-nl "if(vs_top-vs_base<" (length requireds) |
472 |
") too_few_arguments();")) |
") too_few_arguments();")) |
473 |
(unless rest |
(unless rest |
474 |
(wt-nl "if(vs_top-vs_base>" |
(wt-nl "if(vs_top-vs_base>" |
475 |
(+ (length requireds) (length optionals)) |
(+ (length requireds) (length optionals)) |
476 |
") too_many_arguments();"))) |
") too_many_arguments();"))) |
477 |
(t (wt-nl "check_arg(" (length requireds) ");")))) |
(t (wt-nl "check_arg(" (length requireds) ");")))) |
478 |
|
|
479 |
;;; Allocate the parameters. |
;;; Allocate the parameters. |
480 |
(dolist** (var requireds) (setf (var-ref var) (vs-push))) |
(dolist** (var requireds) (setf (var-ref var) (vs-push))) |
481 |
(dolist** (opt optionals) (setf (var-ref (car opt)) (vs-push))) |
(dolist** (opt optionals) (setf (var-ref (car opt)) (vs-push))) |
589 |
) |
) |
590 |
;;; Check arguments. |
;;; Check arguments. |
591 |
(when (and (or *safe-compile* *compiler-check-args*) requireds) |
(when (and (or *safe-compile* *compiler-check-args*) requireds) |
592 |
(when requireds |
(when requireds |
593 |
(wt-nl "if(vs_top-vs_base<" (length requireds) |
(wt-nl "if(vs_top-vs_base<" (length requireds) |
594 |
") too_few_arguments();"))) |
") too_few_arguments();"))) |
595 |
|
|
596 |
;;; Allocate the parameters. |
;;; Allocate the parameters. |
597 |
(dolist** (var requireds) (setf (var-ref var) (vs-push))) |
(dolist** (var requireds) (setf (var-ref var) (vs-push))) |
881 |
|
|
882 |
(defun c2dm (whole env vl body |
(defun c2dm (whole env vl body |
883 |
&aux (cvar (cs-push t t))) |
&aux (cvar (cs-push t t))) |
884 |
; FIXME Compile macros as sfn instead of cf -- need this to guarantee safe calls |
(when (or *safe-compile* *compiler-check-args*) |
885 |
; CM 20040129 |
(wt-nl "check_arg(2);")) |
|
; (when (or *safe-compile* *compiler-check-args*) |
|
|
(wt-nl "check_arg(2);") |
|
|
; ) |
|
886 |
(cond (whole (setf (var-ref whole) (vs-push))) |
(cond (whole (setf (var-ref whole) (vs-push))) |
887 |
(t (vs-push))) |
(t (vs-push))) |
888 |
(cond (env (setf (var-ref env) (vs-push))) |
(cond (env (setf (var-ref env) (vs-push))) |