313 |
|
|
314 |
(dolist (x *function-links* ) |
(dolist (x *function-links* ) |
315 |
(let ((num (second x)) |
(let ((num (second x)) |
316 |
(type (third x))) |
(type (third x)) |
317 |
|
(args (fourth x)) |
318 |
|
(newtype nil)) |
319 |
(cond ((eq type 'proclaimed-closure) |
(cond ((eq type 'proclaimed-closure) |
320 |
(wt-h "static object *Lclptr"num";") |
(wt-h "static object *Lclptr"num";") |
321 |
(setq type "")) |
(setq newtype "")) |
322 |
(t |
(t |
323 |
(setq type (if type (Rep-type type) "")))) |
(setq newtype (if type (Rep-type type) "")))) |
324 |
|
|
325 |
(wt-h "static " (declaration-type type) " LnkT" num "() ;") ;initial function. |
(if (and (not (null type)) |
326 |
#-sgi3d (wt-h "static " (declaration-type type) " (*Lnk" num ")() = LnkT" num ";") |
(not (eq type 'proclaimed-closure)) |
327 |
#+sgi3d (wt-h "static " (declaration-type type) " (*Lnk" num ")();"))) |
(or args (not (eq t type)))) |
328 |
) |
(progn |
329 |
|
(wt-h "static " (declaration-type newtype) " LnkT" num "(object,...);") |
330 |
|
#-sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")() = (" |
331 |
|
(declaration-type newtype) "(*)()) LnkT" num ";") |
332 |
|
#+sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")();")) |
333 |
|
(progn |
334 |
|
(wt-h "static " (declaration-type newtype) " LnkT" num "();") |
335 |
|
#-sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")() = LnkT" num ";") |
336 |
|
#+sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")();")))))) |
337 |
|
) |
338 |
|
|
339 |
|
|
340 |
;; this default will be as close to the the decision of the x3j13 committee |
;; this default will be as close to the the decision of the x3j13 committee |
626 |
(cond ((wt-if-proclaimed fname cfun lambda-expr)) |
(cond ((wt-if-proclaimed fname cfun lambda-expr)) |
627 |
((vararg-p fname) |
((vararg-p fname) |
628 |
(let ((keyp (ll-keywords-p (lambda-list lambda-expr)))) |
(let ((keyp (ll-keywords-p (lambda-list lambda-expr)))) |
629 |
(wt-h "static object LI" cfun "();") |
; (wt-h "static object LI" cfun "();") |
630 |
(if keyp |
(if keyp |
631 |
(add-init `(si::mfvfun-key |
(add-init `(si::mfvfun-key |
632 |
',fname ,(add-address "LI" cfun) |
',fname ,(add-address "LI" cfun) |
771 |
(push (list 'cvar (next-cvar)) reqs)) |
(push (list 'cvar (next-cvar)) reqs)) |
772 |
|
|
773 |
(wt-comment "local entry for function " fname) |
(wt-comment "local entry for function " fname) |
774 |
(wt-h "static object LI" cfun "();") |
|
775 |
(wt-nl1 "static object LI" cfun "(") |
(let ((tmp "")) |
776 |
(wt-list reqs) |
(wt-nl1 "static object LI" cfun "(") |
777 |
(when is-var-arg |
(when reqs |
778 |
(if reqs (wt ",")) |
(do ((v reqs (cdr v))) |
779 |
(wt "va_alist")) |
((null v)) |
780 |
(wt ")") |
(wt "object " (car v)) |
781 |
(when reqs (wt-nl "object ") |
(setq tmp (concatenate 'string tmp "object")) |
782 |
(wt-list reqs) (wt ";")) |
(or (null (cdr v)) |
783 |
(if is-var-arg (wt-nl "va_dcl ")) |
(progn |
784 |
|
(wt ",") |
785 |
|
(setq tmp (concatenate 'string tmp ",")))))) |
786 |
|
(when is-var-arg |
787 |
|
(when reqs (progn (wt ",") (setq tmp (concatenate 'string tmp ",")))) |
788 |
|
(wt "object first,...") |
789 |
|
(setq tmp (concatenate 'string tmp "object,..."))) |
790 |
|
(wt ")") |
791 |
|
(wt-h "static object LI" cfun "(" tmp ");")) |
792 |
|
|
793 |
|
|
794 |
|
; (when reqs (wt-nl "object ") |
795 |
|
; (wt-list reqs) (wt ";")) |
796 |
|
; (if is-var-arg (wt-nl "va_dcl ")) |
797 |
;;; Now the body. |
;;; Now the body. |
798 |
|
|
799 |
(let ((cm *reservation-cmacro*) |
(let ((cm *reservation-cmacro*) |
854 |
|
|
855 |
;;; start va_list at beginning |
;;; start va_list at beginning |
856 |
(if (or (ll-optionals ll) (ll-rest ll) (ll-keywords-p ll)) |
(if (or (ll-optionals ll) (ll-rest ll) (ll-keywords-p ll)) |
857 |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);"))) |
(unless va-start (setq va-start t) (wt-nl "va_start(ap,first);"))) |
858 |
|
|
859 |
;;; Check arguments. |
;;; Check arguments. |
860 |
(when (and (or *safe-compile* *compiler-check-args*) (car ll)) |
(when (and (or *safe-compile* *compiler-check-args*) (car ll)) |
884 |
(*unwind-exit* *unwind-exit*) |
(*unwind-exit* *unwind-exit*) |
885 |
(*ccb-vs* *ccb-vs*)) |
(*ccb-vs* *ccb-vs*)) |
886 |
(wt-nl "narg = narg - " (length reqs) ";") |
(wt-nl "narg = narg - " (length reqs) ";") |
887 |
(dolist** (opt (ll-optionals ll)) |
(let ((first t)) |
888 |
(push (next-label) labels) |
(dolist** (opt (ll-optionals ll)) |
889 |
(wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ") |
(push (next-label) labels) |
890 |
(wt-go (car labels)) |
(wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ") |
891 |
(wt-nl "else {" ) |
(wt-go (car labels)) |
892 |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);")) |
(wt-nl "else {" ) |
893 |
(c2bind-loc (car opt) (list 'next-var-arg)) |
(unless va-start (setq va-start t) (wt-nl "va_start(ap,first);")) |
894 |
(wt "}") |
(c2bind-loc (car opt) (if first (list 'first-var-arg) (list 'next-var-arg))) |
895 |
(when (caddr opt) (c2bind-loc (caddr opt) t)))) |
(setq first nil) |
896 |
|
(wt "}") |
897 |
|
(when (caddr opt) (c2bind-loc (caddr opt) t))))) |
898 |
(setq labels (nreverse labels)) |
(setq labels (nreverse labels)) |
899 |
|
|
900 |
(let ((label (next-label))) |
(let ((label (next-label))) |
917 |
(setq rest-var (cs-push)) |
(setq rest-var (cs-push)) |
918 |
(cond ((ll-optionals ll)) |
(cond ((ll-optionals ll)) |
919 |
(t (wt-nl "narg= narg - " (length (car ll)) ";"))) |
(t (wt-nl "narg= narg - " (length (car ll)) ";"))) |
920 |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);")) |
(unless va-start (setq va-start t) (wt-nl "va_start(ap,first);")) |
921 |
(wt-nl "V" rest-var " = ") |
(wt-nl "V" rest-var " = ") |
922 |
|
|
923 |
(let ((*rest-on-stack* |
(let ((*rest-on-stack* |
928 |
(wt "(ALLOCA_CONS(narg),ON_STACK_MAKE_LIST(narg));")) |
(wt "(ALLOCA_CONS(narg),ON_STACK_MAKE_LIST(narg));")) |
929 |
(t (wt "make_list(narg);"))) |
(t (wt "make_list(narg);"))) |
930 |
(cond (*rest-on-stack* |
(cond (*rest-on-stack* |
931 |
(wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR(narg,ap));" |
(wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR_NEW(narg,first,ap));" |
932 |
)) |
)) |
933 |
(t (wt "list_vector(narg,ap);")))) |
(t (wt "list_vector_new(narg,first,ap);")))) |
934 |
(c2bind-loc (ll-rest ll) (list 'cvar rest-var))))) |
(c2bind-loc (ll-rest ll) (list 'cvar rest-var))))) |
935 |
(when (ll-keywords-p ll) |
(when (ll-keywords-p ll) |
936 |
(cond ((ll-rest ll)) |
(cond ((ll-rest ll)) |
937 |
((ll-optionals ll)) |
((ll-optionals ll)) |
938 |
(t (wt-nl "narg= narg - " (length (car ll)) ";"))) |
(t (wt-nl "narg= narg - " (length (car ll)) ";"))) |
939 |
|
|
940 |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);")) |
(unless va-start (setq va-start t) (wt-nl "va_start(ap,first);")) |
941 |
(setq deflt (mapcar 'caddr (ll-keywords ll))) |
(setq deflt (mapcar 'caddr (ll-keywords ll))) |
942 |
(let ((vkdefaults nil) |
(let ((vkdefaults nil) |
943 |
(n (length (ll-keywords ll)))) |
(n (length (ll-keywords ll)))) |
1008 |
(wt "};") |
(wt "};") |
1009 |
) |
) |
1010 |
(cond ((ll-rest ll) |
(cond ((ll-rest ll) |
1011 |
(wt-nl "parse_key_rest(" (list 'cvar rest-var) ",")) |
(wt-nl "parse_key_rest_new(" (list 'cvar rest-var) ",")) |
1012 |
(t (wt-nl "parse_key_new("))) |
(t (wt-nl "parse_key_new_new("))) |
1013 |
(if (eql 0 *cs*)(setq *cs* 1)) |
(if (eql 0 *cs*)(setq *cs* 1)) |
1014 |
(wt "narg," (if *vararg-use-vs* "base " "Vcs ") |
(wt "narg," (if *vararg-use-vs* "base " "Vcs ") |
1015 |
"+" key-offset",(struct key *)&LI" cfun "key,ap);") |
"+" key-offset",(struct key *)&LI" cfun "key,first,ap);") |
1016 |
|
|
1017 |
)) |
)) |
1018 |
|
|