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

Diff of /gcl/cmpnew/gcl_cmpcall.lsp

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

revision 1.10 by camm, Sat Jul 23 08:47:09 2005 UTC revision 1.11 by camm, Mon Aug 8 22:50:25 2005 UTC
# Line 148  Line 148 
148                         *use-sfuncall*                         *use-sfuncall*
149                         ;;Determine if only one value at most is required:                         ;;Determine if only one value at most is required:
150                         (or                         (or
151                          (eq *value-to-go* 'trash)                          (and (not *values-to-go*) (not (and (consp *value-to-go*) (consp (car *value-to-go*))))
152                          (and (consp *value-to-go*)                               (not (member *value-to-go* '(top return))))
153                               (eq (car *value-to-go*) 'var))  ;                       (eq *value-to-go* 'trash)
154                          (and info (equal (info-type info) '(values t)))  ;                       (and (consp *value-to-go*)
155                          ))  ;                            (eq (car *value-to-go*) 'var))
156                            (and info (equal (info-type info) '(values t)))))
157                    (c2funcall-sfun form args info)                    (c2funcall-sfun form args info)
158                    (return-from c2funcall nil)))                    (return-from c2funcall nil)))
159             (unless loc             (unless loc
# Line 180  Line 181 
181    (unless (and (consp f) (eq (car f) 'var))    (unless (and (consp f) (eq (car f) 'var))
182            (setq f (list 'cvar (cs-push)))            (setq f (list 'cvar (cs-push)))
183            (wt-nl f " = " (car args) ","))            (wt-nl f " = " (car args) ","))
184     (wt-nl "(type_of(" f ") == t_sfun ?"     (wt-nl "({object _ob=" f ";enum type _tp=type_of(_ob);if (_tp==t_symbol) {_ob=_ob->s.s_gfdef;_tp=type_of(_ob);}")
185       (wt-nl "(_tp == t_sfun ?"
186  ;         "(*(object (*)())((" f ")->sfn.sfn_self)):")  ;         "(*(object (*)())((" f ")->sfn.sfn_self)):")
187            "(*((" f ")->sfn.sfn_self)):")            "(*((_ob)->sfn.sfn_self)):")
188     (when (< *space* 3)     (when (< *space* 3)
189           (setq length t)           (setq length t)
190           (wt-nl "(fcall.argd="  (length (cdr args)) ",type_of("f")==t_vfun) ?")           (wt-nl "(fcall.argd="  (length (cdr args)) ",_tp==t_vfun) ?")
191  ;        (wt-nl  "(*(object (*)())((" f ")->sfn.sfn_self)):"))  ;        (wt-nl  "(*(object (*)())((" f ")->sfn.sfn_self)):"))
192           (wt-nl  "(*((" f ")->sfn.sfn_self)):"))           (wt-nl  "(*((_ob)->sfn.sfn_self)):"))
193     (wt-nl  "(fcall.fun=(" f "),")     (wt-nl  "(fcall.fun=(_ob),")
194     (unless length     (unless length
195             (wt "fcall.argd="  (length (cdr args)) ","))             (wt "fcall.argd="  (length (cdr args)) ","))
196     (wt   "fcalln))(")     (wt   "fcalln));})(")
197     (when (cdr args) (wt (cadr args))     (when (cdr args) (wt (cadr args))
198           (dolist (loc (cddr args)) (wt #\, loc)))           (dolist (loc (cddr args)) (wt #\, loc)))
199     (wt #\) #\)  ))     (wt #\) #\)  ))

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

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