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

Diff of /gcl/cmpnew/gcl_cmptop.lsp

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

revision 1.17 by mjthomas, Tue Nov 23 07:30:24 2004 UTC revision 1.18 by camm, Tue Dec 14 03:34:06 2004 UTC
# Line 769  Line 769 
769      ;;; Local entry      ;;; Local entry
770      (analyze-regs (cadr lambda-expr) 0)      (analyze-regs (cadr lambda-expr) 0)
771      (t3defun-aux 't3defun-local-entry      (t3defun-aux 't3defun-local-entry
772                   (case (caddr inline-info)                   (case (promoted-c-type (caddr inline-info))
773                     (fixnum 'return-fixnum)                     (fixnum 'return-fixnum)
774                           (character 'return-character)                     (character 'return-character)
775                           (long-float 'return-long-float)                     (long-float 'return-long-float)
776                           (short-float 'return-short-float)                     (short-float 'return-short-float)
777                           (otherwise 'return-object))                     (otherwise 'return-object))
778                   fname cfun lambda-expr sp inline-info                   fname cfun lambda-expr sp inline-info
779      ))      ))
780     ((vararg-p fname)     ((vararg-p fname)
# Line 802  Line 802 
802                (push (cons (car vl) (var-loc (car vl))) specials))                (push (cons (car vl) (var-loc (car vl))) specials))
803              (t              (t
804               (setf (var-kind (car vl))               (setf (var-kind (car vl))
805                     (case (car types)                     (case (promoted-c-type (car types))
806                           (fixnum 'FIXNUM)                           (fixnum 'FIXNUM)
807                           (character 'CHARACTER)                           (character 'CHARACTER)
808                           (long-float 'LONG-FLOAT)                           (long-float 'LONG-FLOAT)
# Line 1325  Line 1325 
1325      (wt-nl1 "{  register object *base=vs_base;")      (wt-nl1 "{  register object *base=vs_base;")
1326      (when (or *safe-compile* *compiler-check-args*)      (when (or *safe-compile* *compiler-check-args*)
1327            (wt-nl "check_arg(" (length arg-types) ");"))            (wt-nl "check_arg(" (length arg-types) ");"))
1328      (wt-nl "base[0]=" (case return-type      (wt-nl "base[0]=" (case (promoted-c-type return-type)
1329                              (fixnum (if (zerop *space*)                              (fixnum (if (zerop *space*)
1330                                          "CMPmake_fixnum"                                          "CMPmake_fixnum"
1331                                          "make_fixnum"))                                          "make_fixnum"))
# Line 1338  Line 1338 
1338           (n 0 (1+ n)))           (n 0 (1+ n)))
1339          ((endp types))          ((endp types))
1340          (declare (object types) (fixnum n))          (declare (object types) (fixnum n))
1341          (wt (case (car types)          (wt (case (promoted-c-type (car types))
1342                    (fixnum "fix")                    (fixnum "fix")
1343                    (character "char_code")                    (character "char_code")
1344                    (long-float "lf")                    (long-float "lf")
# Line 1352  Line 1352 
1352      )      )
1353    
1354  (defun rep-type (type)  (defun rep-type (type)
1355         (case type    (case (promoted-c-type type)
1356               (fixnum "long ")      (fixnum "long ")
1357               (integer "GEN ")      (integer "GEN ")
1358               (character "unsigned char ")      (character "unsigned char ")
1359               (short-float "float ")      (short-float "float ")
1360               (long-float "double ")      (long-float "double ")
1361               (otherwise "object ")))      (otherwise "object ")))
1362    
1363    
1364  (defun t1defmacro (args)  (defun t1defmacro (args)

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18

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