/[gcl]/gcl/cmpnew/cmptop.lsp
ViewVC logotype

Diff of /gcl/cmpnew/cmptop.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by camm, Fri Jan 24 18:38:28 2003 UTC revision 1.6 by camm, Sun Feb 9 22:35:14 2003 UTC
# Line 313  Line 313 
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
# Line 615  Line 626 
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)
# Line 760  Line 771 
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*)
# Line 830  Line 854 
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))
# Line 860  Line 884 
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)))
# Line 891  Line 917 
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*
# Line 902  Line 928 
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))))
# Line 982  Line 1008 
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            

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26