227 |
(setq *top-level-forms* (reverse *top-level-forms*)) |
(setq *top-level-forms* (reverse *top-level-forms*)) |
228 |
|
|
229 |
;;; Initialization function. |
;;; Initialization function. |
230 |
(wt-nl1 "init_" name "(){" |
(wt-nl1 "void init_" name "(){" |
231 |
#+sgi3d "Init_Links ();" |
#+sgi3d "Init_Links ();" |
232 |
"do_init(VV);" |
"do_init(VV);" |
233 |
"}") |
"}") |
266 |
) |
) |
267 |
#+sgi3d |
#+sgi3d |
268 |
(progn |
(progn |
269 |
(wt-nl1 "" "static Init_Links () {") |
(wt-nl1 "" "static void Init_Links () {") |
270 |
(dolist* (x *function-links*) |
(dolist* (x *function-links*) |
271 |
(let ((num (second x))) |
(let ((num (second x))) |
272 |
(wt-nl "Lnk" num " = LnkT" num ";"))) |
(wt-nl "Lnk" num " = LnkT" num ";"))) |
273 |
(wt-nl1 "}")) |
(wt-nl1 "}")) |
274 |
|
|
275 |
;;; Declarations in h-file. |
;;; Declarations in h-file. |
276 |
(dolist* (fun *closures*) (wt-h "static LC" (fun-cfun fun) "();")) |
(dolist* (fun *closures*) (wt-h "static void LC" (fun-cfun fun) "();")) |
277 |
(dolist* (x *reservations*) |
(dolist* (x *reservations*) |
278 |
(wt-h "#define VM" (car x) " " (cdr x))) |
(wt-h "#define VM" (car x) " " (cdr x))) |
279 |
|
|
315 |
(t |
(t |
316 |
(setq type (if type (Rep-type type) "")))) |
(setq type (if type (Rep-type type) "")))) |
317 |
|
|
318 |
(wt-h "static " type " LnkT" num "() ;") ;initial function. |
(wt-h "static " (if (equal type "") "void" type) " LnkT" num "() ;") ;initial function. |
319 |
#-sgi3d (wt-h "static " type " (*Lnk" num ")() = LnkT" num ";") |
#-sgi3d (wt-h "static " (if (equal type "") "void" type) " (*Lnk" num ")() = LnkT" num ";") |
320 |
#+sgi3d (wt-h "static " type " (*Lnk" num ")();"))) |
#+sgi3d (wt-h "static " (if (equal type "") "void" type) " (*Lnk" num ")();"))) |
321 |
) |
) |
322 |
|
|
323 |
|
|
620 |
(maxargs (lambda-list lambda-expr)))) |
(maxargs (lambda-list lambda-expr)))) |
621 |
)))) |
)))) |
622 |
((numberp cfun) |
((numberp cfun) |
623 |
(wt-h "static L" cfun "();") |
(wt-h "static void L" cfun "();") |
624 |
(add-init `(si::mf ',fname ,(add-address "L" cfun)) )) |
(add-init `(si::mf ',fname ,(add-address "L" cfun)) )) |
625 |
(t (wt-h cfun "();") |
(t (wt-h cfun "();") |
626 |
(add-init `(si::mf ',fname ,(add-address "" cfun )) ))) |
(add-init `(si::mf ',fname ,(add-address "" cfun )) ))) |
713 |
(when *compiler-push-events* (wt-nl "ihs_check;")) |
(when *compiler-push-events* (wt-nl "ihs_check;")) |
714 |
(when *tail-recursion-info* |
(when *tail-recursion-info* |
715 |
(push 'tail-recursion-mark *unwind-exit*) |
(push 'tail-recursion-mark *unwind-exit*) |
716 |
(wt-nl1 "TTL:;")) |
(wt-nl1 "goto TTL;") (wt-nl1 "TTL:;")) |
717 |
(dolist |
(dolist |
718 |
(v specials) |
(v specials) |
719 |
(wt-nl "bds_bind(VV[" (cdr v)"],V" (var-loc (car v))");") |
(wt-nl "bds_bind(VV[" (cdr v)"],V" (var-loc (car v))");") |
722 |
(setf (var-loc (car v)) (cdr v))) |
(setf (var-loc (car v)) (cdr v))) |
723 |
(c2expr (caddr (cddr lambda-expr))) |
(c2expr (caddr (cddr lambda-expr))) |
724 |
|
|
725 |
|
;;; Use base if defined for lint |
726 |
|
(if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) |
727 |
|
|
728 |
|
;;; Make sure to return object if necessary |
729 |
|
(if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;")) |
730 |
|
|
731 |
(wt-nl1 "}") |
(wt-nl1 "}") |
732 |
(wt-V*-macros cm (caddr inline-info)) |
(wt-V*-macros cm (caddr inline-info)) |
733 |
)) |
)) |
817 |
(when (cadddr kwd) (do-decl (cadddr kwd)))) |
(when (cadddr kwd) (do-decl (cadddr kwd)))) |
818 |
) |
) |
819 |
|
|
820 |
|
;;; Use Vcs for lint |
821 |
|
(if *vararg-use-vs* t (progn (wt-nl "Vcs[0]=Vcs[0];"))) |
822 |
|
|
823 |
|
;;; start va_list at beginning |
824 |
|
(if (or (ll-optionals ll) (ll-rest ll) (ll-keywords-p ll)) |
825 |
|
(unless va-start (setq va-start t) (wt-nl "va_start(ap);"))) |
826 |
|
|
827 |
;;; Check arguments. |
;;; Check arguments. |
828 |
(when (and (or *safe-compile* *compiler-check-args*) (car ll)) |
(when (and (or *safe-compile* *compiler-check-args*) (car ll)) |
829 |
(wt-nl "if(narg <" (length (car ll)) |
(wt-nl "if(narg <" (length (car ll)) |
847 |
(vl (car ll) (cdr vl))) |
(vl (car ll) (cdr vl))) |
848 |
((null v)) |
((null v)) |
849 |
(c2bind-loc (car vl) (car v))) |
(c2bind-loc (car vl) (car v))) |
850 |
(when (ll-optionals ll) |
(when (ll-optionals ll) |
851 |
(let ((*clink* *clink*) |
(let ((*clink* *clink*) |
852 |
(*unwind-exit* *unwind-exit*) |
(*unwind-exit* *unwind-exit*) |
853 |
(*ccb-vs* *ccb-vs*)) |
(*ccb-vs* *ccb-vs*)) |
854 |
(wt-nl "narg = narg - " (length reqs) ";") |
(wt-nl "narg = narg - " (length reqs) ";") |
855 |
(dolist** (opt (ll-optionals ll)) |
(dolist** (opt (ll-optionals ll)) |
856 |
(push (next-label) labels) |
(push (next-label) labels) |
857 |
(wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ") |
(wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ") |
858 |
(wt-go (car labels)) |
(wt-go (car labels)) |
859 |
(wt-nl "else {" ) |
(wt-nl "else {" ) |
860 |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);")) |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);")) |
861 |
(c2bind-loc (car opt) (list 'next-var-arg)) |
(c2bind-loc (car opt) (list 'next-var-arg)) |
862 |
(wt "}") |
(wt "}") |
863 |
(when (caddr opt) (c2bind-loc (caddr opt) t)))) |
(when (caddr opt) (c2bind-loc (caddr opt) t)))) |
864 |
(setq labels (nreverse labels)) |
(setq labels (nreverse labels)) |
865 |
|
|
866 |
(let ((label (next-label))) |
(let ((label (next-label))) |
867 |
(wt-nl "--narg; ") |
(wt-nl "--narg; ") |
868 |
(wt-go label) |
(wt-go label) |
869 |
|
|
870 |
;;; Bind unspecified optional parameters. |
;;; Bind unspecified optional parameters. |
871 |
|
|
872 |
(dolist** (opt (ll-optionals ll)) |
(dolist** (opt (ll-optionals ll)) |
873 |
(wt-label (car labels)) |
(wt-label (car labels)) |
874 |
(pop labels) |
(pop labels) |
875 |
(c2bind-init (car opt) (cadr opt)) |
(c2bind-init (car opt) (cadr opt)) |
876 |
(when (caddr opt) (c2bind-loc (caddr opt) nil))) |
(when (caddr opt) (c2bind-loc (caddr opt) nil))) |
877 |
; (if (or (ll-rest ll)(ll-keywords-p ll))(wt-nl "narg=0;")) |
; (if (or (ll-rest ll)(ll-keywords-p ll))(wt-nl "narg=0;")) |
878 |
|
|
879 |
(wt-label label) |
(wt-label label) |
880 |
)) |
)) |
881 |
(if (ll-rest ll) |
(if (ll-rest ll) |
882 |
(progn |
(progn |
883 |
(setq rest-var (cs-push)) |
(setq rest-var (cs-push)) |
884 |
(cond ((ll-optionals ll)) |
(cond ((ll-optionals ll)) |
885 |
(t (wt-nl "narg= narg - " (length (car ll)) ";"))) |
(t (wt-nl "narg= narg - " (length (car ll)) ";"))) |
886 |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);")) |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);")) |
887 |
(wt-nl "V" rest-var " = ") |
(wt-nl "V" rest-var " = ") |
888 |
|
|
889 |
(let ((*rest-on-stack* |
(let ((*rest-on-stack* |
890 |
(or (eq (var-type (ll-rest ll)) :dynamic-extent) |
(or (eq (var-type (ll-rest ll)) :dynamic-extent) |
891 |
*rest-on-stack*))) |
*rest-on-stack*))) |
892 |
(if (ll-keywords-p ll) |
(if (ll-keywords-p ll) |
893 |
(cond (*rest-on-stack* |
(cond (*rest-on-stack* |
894 |
(wt "(ALLOCA_CONS(narg),ON_STACK_MAKE_LIST(narg));")) |
(wt "(ALLOCA_CONS(narg),ON_STACK_MAKE_LIST(narg));")) |
895 |
(t (wt "make_list(narg);"))) |
(t (wt "make_list(narg);"))) |
896 |
(cond (*rest-on-stack* |
(cond (*rest-on-stack* |
897 |
(wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR(narg,ap));" |
(wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR(narg,ap));" |
898 |
)) |
)) |
899 |
(t (wt "list_vector(narg,ap);")))) |
(t (wt "list_vector(narg,ap);")))) |
900 |
(c2bind-loc (ll-rest ll) (list 'cvar rest-var))))) |
(c2bind-loc (ll-rest ll) (list 'cvar rest-var))))) |
901 |
(when (ll-keywords-p ll) |
(when (ll-keywords-p ll) |
902 |
(cond ((ll-rest ll)) |
(cond ((ll-rest ll)) |
903 |
((ll-optionals ll)) |
((ll-optionals ll)) |
904 |
(t (wt-nl "narg= narg - " (length (car ll)) ";"))) |
(t (wt-nl "narg= narg - " (length (car ll)) ";"))) |
905 |
|
|
906 |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);")) |
(unless va-start (setq va-start t) (wt-nl "va_start(ap);")) |
907 |
(setq deflt (mapcar 'caddr (ll-keywords ll))) |
(setq deflt (mapcar 'caddr (ll-keywords ll))) |
908 |
(let ((vkdefaults nil) |
(let ((vkdefaults nil) |
909 |
(n (length (ll-keywords ll)))) |
(n (length (ll-keywords ll)))) |
910 |
(do* ((v deflt (cdr v)) |
(do* ((v deflt (cdr v)) |
911 |
(kwds (ll-keywords ll) (cdr kwds)) |
(kwds (ll-keywords ll) (cdr kwds)) |
912 |
(kwd (car kwds) (car kwds))) |
(kwd (car kwds) (car kwds))) |
913 |
((null v)) |
((null v)) |
914 |
(unless (and (eq (caar v) 'location) |
(unless (and (eq (caar v) 'location) |
915 |
(eq (third (car v)) nil)) |
(eq (third (car v)) nil)) |
916 |
(setq vkdefaults t)) |
(setq vkdefaults t)) |
917 |
(when (or (not (and (eq (caar v) 'location) |
(when (or (not (and (eq (caar v) 'location) |
918 |
(let ((tem (third (car v)))) |
(let ((tem (third (car v)))) |
919 |
(or (eq tem nil) |
(or (eq tem nil) |
923 |
))))) |
))))) |
924 |
;; the supplied-p variable is not there |
;; the supplied-p variable is not there |
925 |
(not (eq (var-kind (cadddr kwd)) 'DUMMY))) |
(not (eq (var-kind (cadddr kwd)) 'DUMMY))) |
926 |
(setf Vkdefaults t) |
(setf Vkdefaults t) |
927 |
(setf (car v) 0))) |
(setf (car v) 0))) |
928 |
(if (> (length deflt) 15) (setq vkdefaults t)) |
(if (> (length deflt) 15) (setq vkdefaults t)) |
929 |
|
|
930 |
(wt-nl "{") |
(wt-nl "{") |
931 |
(inc-inline-blocks) |
(inc-inline-blocks) |
932 |
(let ((*compiler-output1* *compiler-output2*)) |
(let ((*compiler-output1* *compiler-output2*)) |
933 |
(when vkdefaults |
(when vkdefaults |
934 |
(terpri *compiler-output2*) |
(terpri *compiler-output2*) |
935 |
(wt "static object VK" cfun |
(wt "static object VK" cfun |
936 |
"defaults[" (length deflt) "]={") |
"defaults[" (length deflt) "]={") |
937 |
(do ((v deflt(cdr v))(tem)) |
(do ((v deflt(cdr v))(tem)) |
938 |
((null v)) |
((null v)) |
939 |
(wt "(void *)") |
(wt "(void *)") |
940 |
(cond ((eql (car v) 0) |
(cond ((eql (car v) 0) |
941 |
(wt "-1")) |
(wt "-1")) |
942 |
;; must be location |
;; must be location |
943 |
((and (eq (setq tem (third (car v))) nil)) |
((and (eq (setq tem (third (car v))) nil)) |
944 |
(wt "-2")) |
(wt "-2")) |
945 |
((and (consp tem) (eq (car tem) 'vv)) |
((and (consp tem) (eq (car tem) 'vv)) |
946 |
(wt (second tem) )) |
(wt (second tem) )) |
947 |
((and (consp tem) (eq (car tem) 'fixnum-value)) |
((and (consp tem) (eq (car tem) 'fixnum-value)) |
948 |
(wt (add-object(third tem)) )) |
(wt (add-object(third tem)) )) |
949 |
(t (baboon))) |
(t (baboon))) |
|
|
|
|
(if (cdr v) (wt ","))) |
|
|
(wt "};")) |
|
|
(terpri *compiler-output2*) |
|
|
(wt "static struct { short n,allow_other_keys;" |
|
|
"object *defaults;") |
|
|
(wt-nl " KEYTYPE keys[" (max n 1) "];") |
|
|
(wt "} LI"cfun "key=") |
|
950 |
|
|
951 |
(wt "{" (length (ll-keywords ll)) "," |
(if (cdr v) (wt ","))) |
952 |
(if (ll-allow-other-keys ll) 1 0) |
(wt "};")) |
953 |
",") |
(terpri *compiler-output2*) |
954 |
(if vkdefaults (wt "VK" cfun "defaults") |
(wt "static struct { short n,allow_other_keys;" |
955 |
(wt "Cstd_key_defaults")) |
"object *defaults;") |
956 |
(when (ll-keywords ll) |
(wt-nl " KEYTYPE keys[" (max n 1) "];") |
957 |
(wt ",{") |
(wt "} LI"cfun "key=") |
958 |
(do ((v (reverse (ll-keywords ll)) (cdr v))) |
|
959 |
((null v)) |
(wt "{" (length (ll-keywords ll)) "," |
960 |
;; We write this list backwards for convenience |
(if (ll-allow-other-keys ll) 1 0) |
961 |
;; in stepping through it in parse_key |
",") |
962 |
(wt "(void *)") |
(if vkdefaults (wt "VK" cfun "defaults") |
963 |
(wt (add-symbol (caar v)) ) |
(wt "Cstd_key_defaults")) |
964 |
(if (cdr v) (wt ","))) |
(when (ll-keywords ll) |
965 |
(wt "}")) |
(wt ",{") |
966 |
(wt "};") |
(do ((v (reverse (ll-keywords ll)) (cdr v))) |
967 |
) |
((null v)) |
968 |
(cond ((ll-rest ll) |
;; We write this list backwards for convenience |
969 |
(wt-nl "parse_key_rest(" (list 'cvar rest-var) ",")) |
;; in stepping through it in parse_key |
970 |
(t (wt-nl "parse_key_new("))) |
(wt "(void *)") |
971 |
(if (eql 0 *cs*)(setq *cs* 1)) |
(wt (add-symbol (caar v)) ) |
972 |
(wt "narg," (if *vararg-use-vs* "base " "Vcs ") |
(if (cdr v) (wt ","))) |
973 |
"+" key-offset",&LI" cfun "key,ap);") |
(wt "}")) |
974 |
|
(wt "};") |
975 |
)) |
) |
976 |
|
(cond ((ll-rest ll) |
977 |
|
(wt-nl "parse_key_rest(" (list 'cvar rest-var) ",")) |
978 |
|
(t (wt-nl "parse_key_new("))) |
979 |
;; bind keywords |
(if (eql 0 *cs*)(setq *cs* 1)) |
980 |
|
(wt "narg," (if *vararg-use-vs* "base " "Vcs ") |
981 |
|
"+" key-offset",(struct key *)&LI" cfun "key,ap);") |
982 |
|
|
983 |
|
)) |
984 |
|
|
985 |
|
|
986 |
|
|
987 |
|
;; bind keywords |
988 |
|
|
989 |
|
(dolist** (kwd (ll-keywords ll)) |
990 |
|
(cond ((not (eql 0 (pop deflt))) |
991 |
|
;; keyword default bound by parse_key.. and no supplied-p |
992 |
|
(c2bind (cadr kwd))) |
993 |
|
(t |
994 |
|
(wt-nl "if(") (wt-vs (var-ref (cadr kwd))) (wt "==0){") |
995 |
|
(let ((*clink* *clink*) |
996 |
|
(*unwind-exit* *unwind-exit*) |
997 |
|
(*ccb-vs* *ccb-vs*)) |
998 |
|
(c2bind-init (cadr kwd) (caddr kwd))) |
999 |
|
(unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) nil)) |
1000 |
|
|
1001 |
|
(wt-nl "}else{") |
1002 |
|
(c2bind (cadr kwd)) |
1003 |
|
(unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) |
1004 |
|
t)) |
1005 |
|
|
1006 |
|
(wt "}"))) |
1007 |
|
|
1008 |
|
|
1009 |
|
|
1010 |
|
) |
1011 |
|
|
1012 |
(dolist** (kwd (ll-keywords ll)) |
(when *tail-recursion-info* |
1013 |
(cond ((not (eql 0 (pop deflt))) |
(push 'tail-recursion-mark *unwind-exit*) |
1014 |
;; keyword default bound by parse_key.. and no supplied-p |
(wt-nl1 "goto TTL;") (wt-nl1 "TTL:;")) |
1015 |
(c2bind (cadr kwd))) |
(c2expr (caddr (cddr lambda-expr))) |
1016 |
(t |
|
1017 |
(wt-nl "if(") (wt-vs (var-ref (cadr kwd))) (wt "==0){") |
;;; End va_list at function end |
|
(let ((*clink* *clink*) |
|
|
(*unwind-exit* *unwind-exit*) |
|
|
(*ccb-vs* *ccb-vs*)) |
|
|
(c2bind-init (cadr kwd) (caddr kwd))) |
|
|
(unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) nil)) |
|
|
|
|
|
(wt-nl "}else{") |
|
|
(c2bind (cadr kwd)) |
|
|
(unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) |
|
|
t)) |
|
1018 |
|
|
1019 |
(wt "}"))) |
(when va-start (setq va-start nil) (wt-nl "va_end(ap);")) |
1020 |
|
|
1021 |
|
;;; Use base if defined for lint |
1022 |
|
(if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) |
1023 |
|
|
1024 |
|
;;; Need to ensure return of type object |
1025 |
|
(wt-nl "return Cnil;") |
1026 |
|
|
1027 |
) |
(wt "}") |
1028 |
(when *tail-recursion-info* |
(when block-p (wt-nl "}")) |
1029 |
(push 'tail-recursion-mark *unwind-exit*) |
(close-inline-blocks) |
1030 |
(wt-nl1 "TTL:;")) |
(wt-V*-macros cm (get fname 'proclaimed-return-type)) |
1031 |
(c2expr (caddr (cddr lambda-expr))) |
)) |
|
|
|
|
(wt "}") |
|
|
(when block-p (wt-nl "}")) |
|
|
(close-inline-blocks) |
|
|
(wt-V*-macros cm (get fname 'proclaimed-return-type)) |
|
|
)) |
|
1032 |
|
|
1033 |
(defun t3defun-normal (fname cfun lambda-expr sp) |
(defun t3defun-normal (fname cfun lambda-expr sp) |
1034 |
(wt-comment "function definition for " fname) |
(wt-comment "function definition for " fname) |
1035 |
(if (numberp cfun) |
(if (numberp cfun) |
1036 |
(wt-nl1 "static L" cfun "()") |
(wt-nl1 "static void L" cfun "()") |
1037 |
(wt-nl1 cfun "()")) |
(wt-nl1 cfun "()")) |
1038 |
(wt-nl1 "{" "register object *" *volatile*"base=vs_base;") |
(wt-nl1 "{" "register object *" *volatile*"base=vs_base;") |
1039 |
(assign-down-vars (info-referred-vars (cadr lambda-expr)) cfun |
(assign-down-vars (info-referred-vars (cadr lambda-expr)) cfun |
1188 |
(defun wt-global-entry (fname cfun arg-types return-type) |
(defun wt-global-entry (fname cfun arg-types return-type) |
1189 |
(cond ((get fname 'no-global-entry)(return-from wt-global-entry nil))) |
(cond ((get fname 'no-global-entry)(return-from wt-global-entry nil))) |
1190 |
(wt-comment "global entry for the function " fname) |
(wt-comment "global entry for the function " fname) |
1191 |
(wt-nl1 "static L" cfun "()") |
(wt-nl1 "static void L" cfun "()") |
1192 |
(wt-nl1 "{ register object *base=vs_base;") |
(wt-nl1 "{ register object *base=vs_base;") |
1193 |
(when (or *safe-compile* *compiler-check-args*) |
(when (or *safe-compile* *compiler-check-args*) |
1194 |
(wt-nl "check_arg(" (length arg-types) ");")) |
(wt-nl "check_arg(" (length arg-types) ");")) |
1254 |
(when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation) )) |
(when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation) )) |
1255 |
(when ppn |
(when ppn |
1256 |
(add-init `(si::putprop ',fname ',ppn 'si::pretty-print-format) )) |
(add-init `(si::putprop ',fname ',ppn 'si::pretty-print-format) )) |
1257 |
(wt-h "static L" cfun "();") |
(wt-h "static void L" cfun "();") |
1258 |
(add-init `(si::MM ',fname ,(add-address "L" cfun)) ) |
(add-init `(si::MM ',fname ,(add-address "L" cfun)) ) |
1259 |
) |
) |
1260 |
|
|
1265 |
(let-pass3 |
(let-pass3 |
1266 |
((*exit* 'return)) |
((*exit* 'return)) |
1267 |
(wt-comment "macro definition for " fname) |
(wt-comment "macro definition for " fname) |
1268 |
(wt-nl1 "static L" cfun "()") |
(wt-nl1 "static void L" cfun "()") |
1269 |
(wt-nl1 "{register object *" *volatile* "base=vs_base;") |
(wt-nl1 "{register object *" *volatile* "base=vs_base;") |
1270 |
(assign-down-vars (info-referred-vars (nth 4 macro-lambda)) cfun ;*dm-info* |
(assign-down-vars (info-referred-vars (nth 4 macro-lambda)) cfun ;*dm-info* |
1271 |
't3defun) |
't3defun) |
1504 |
|
|
1505 |
(defun t2defentry (fname cfun arg-types type cname) |
(defun t2defentry (fname cfun arg-types type cname) |
1506 |
(declare (ignore arg-types type cname)) |
(declare (ignore arg-types type cname)) |
1507 |
(wt-h "static L" cfun "();") |
(wt-h "static void L" cfun "();") |
1508 |
(add-init `(si::mf ',fname ,(add-address "L" cfun)) ) |
(add-init `(si::mf ',fname ,(add-address "L" cfun)) ) |
1509 |
) |
) |
1510 |
|
|
1511 |
(defun t3defentry (fname cfun arg-types type cname) |
(defun t3defentry (fname cfun arg-types type cname) |
1512 |
(wt-comment "function definition for " fname) |
(wt-comment "function definition for " fname) |
1513 |
(wt-nl1 "static L" cfun "()") |
(wt-nl1 "static void L" cfun "()") |
1514 |
(wt-nl1 "{ object *old_base=vs_base;") |
(wt-nl1 "{ object *old_base=vs_base;") |
1515 |
(case type |
(case type |
1516 |
(void) |
(void) |
1579 |
*downward-closures* |
*downward-closures* |
1580 |
(requireds (caaddr lambda-expr))) |
(requireds (caaddr lambda-expr))) |
1581 |
(wt-comment "local dc function " (if (fun-name fun) (fun-name fun) nil)) |
(wt-comment "local dc function " (if (fun-name fun) (fun-name fun) nil)) |
1582 |
(wt-nl1 "static " (if closure-p "LC" "L") (fun-cfun fun) "(") |
(wt-nl1 "static void " (if closure-p "LC" "L") (fun-cfun fun) "(") |
1583 |
(wt "base0" (if requireds "," "")) |
(wt "base0" (if requireds "," "")) |
1584 |
(analyze-regs (info-referred-vars (cadr lambda-expr)) 2) |
(analyze-regs (info-referred-vars (cadr lambda-expr)) 2) |
1585 |
(wt-requireds (caaddr lambda-expr) nil) ;;nil = arg types all t |
(wt-requireds (caaddr lambda-expr) nil) ;;nil = arg types all t |
1596 |
(when *compiler-push-events* (wt-nl "ihs_check;")) |
(when *compiler-push-events* (wt-nl "ihs_check;")) |
1597 |
(c2expr (caddr (cddr lambda-expr))) |
(c2expr (caddr (cddr lambda-expr))) |
1598 |
;(c2lambda-expr (lambda-list lambda-expr) (caddr (cddr lambda-expr))) |
;(c2lambda-expr (lambda-list lambda-expr) (caddr (cddr lambda-expr))) |
1599 |
|
;;; Use base if defined for lint |
1600 |
|
(if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) |
1601 |
(wt-nl1 "}") |
(wt-nl1 "}") |
1602 |
(wt-V*-macros cm t) |
(wt-V*-macros cm t) |
1603 |
(wt-downward-closure-macro (fun-cfun fun)) |
(wt-downward-closure-macro (fun-cfun fun)) |
1613 |
(return-from t3local-fun |
(return-from t3local-fun |
1614 |
(t3local-dcfun closure-p clink ccb-vs fun lambda-expr))) |
(t3local-dcfun closure-p clink ccb-vs fun lambda-expr))) |
1615 |
(wt-comment "local function " (if (fun-name fun) (fun-name fun) nil)) |
(wt-comment "local function " (if (fun-name fun) (fun-name fun) nil)) |
1616 |
(wt-h "static " (if closure-p "LC" "L") (fun-cfun fun) "();") |
(wt-h "static void " (if closure-p "LC" "L") (fun-cfun fun) "();") |
1617 |
(wt-nl1 "static " (if closure-p "LC" "L") (fun-cfun fun) "(") |
(wt-nl1 "static void " (if closure-p "LC" "L") (fun-cfun fun) "(") |
1618 |
(dotimes* (n level (wt "base" n ")")) (wt "base" n ",")) |
(dotimes* (n level (wt "base" n ")")) (wt "base" n ",")) |
1619 |
(wt-nl1 "register object ") |
(wt-nl1 "register object ") |
1620 |
(dotimes* (n level (wt "*"*volatile*"base" n ";")) |
(dotimes* (n level (wt "*"*volatile*"base" n ";")) |
1660 |
)) |
)) |
1661 |
(and *c-vars* (format *compiler-output2* ";")) |
(and *c-vars* (format *compiler-output2* ";")) |
1662 |
(unless (eql *cs* 0) |
(unless (eql *cs* 0) |
1663 |
|
; (format *compiler-output2* " object Vcs[~a]={Cnil" *cs*) |
1664 |
|
; (dotimes (temp (- *cs* 1) t) (format *compiler-output2* ",Cnil")) |
1665 |
|
; (format *compiler-output2* "};")) |
1666 |
(format *compiler-output2* " object Vcs[~a];" *cs*)) |
(format *compiler-output2* " object Vcs[~a];" *cs*)) |
1667 |
) |
) |
1668 |
|
|