Changeset 11927 for release/1.3


Ignore:
Timestamp:
Apr 9, 2009, 10:16:42 PM (10 years ago)
Author:
rme
Message:

Merge trunk changes r11863 through r11898.

Location:
release/1.3/source
Files:
22 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/1.3/source/cocoa-ide/app-delegate.lisp

    r11214 r11927  
    152152    (#/newListener: self app)
    153153    t))
     154
     155(objc:defmethod (#/loadFile: :void) ((self lisp-application-delegate) sender)
     156  (declare (ignore sender))
     157  (let ((filename (cocoa-choose-file-dialog
     158                   :button-string "Load"
     159                   :file-types (list (pathname-type *.lisp-pathname*)
     160                                     (pathname-type *.fasl-pathname*)))))
     161    (when filename
     162      (#/ensureListener: self nil)
     163      (let* ((doc (#/topListener hemlock-listener-document))
     164             (process (hemlock-document-process doc)))
     165        (process-interrupt process #'(lambda ()
     166                                       (load filename)
     167                                       (fresh-line)))))))
     168
     169(objc:defmethod (#/compileFile: :void) ((self lisp-application-delegate) sender)
     170  (declare (ignore sender))
     171  (let ((filename (cocoa-choose-file-dialog
     172                   :button-string "Compile"
     173                   :file-types (list (pathname-type *.lisp-pathname*)))))
     174    (when filename
     175      (#/ensureListener: self nil)
     176      (let* ((doc (#/topListener hemlock-listener-document))
     177             (process (hemlock-document-process doc)))
     178        (process-interrupt process #'(lambda ()
     179                                       (compile-file filename)
     180                                       (fresh-line)))))))
     181
  • release/1.3/source/cocoa-ide/defsystem.lisp

    r9759 r11927  
    7575    "processes-window"
    7676    "apropos-window"
     77    "file-dialogs"
    7778    "app-delegate"
    7879    "ide-self-update"
  • release/1.3/source/cocoa-ide/hemlock/src/bindings.lisp

    r11923 r11927  
    331331;;;; Listener and Editor Modes.
    332332(bind-key "Confirm Listener Input" #k"return" :mode "Listener")
     333(bind-key "Confirm Listener Input" #k"shift-return" :mode "Listener")
    333334(bind-key "Previous Interactive Input" #k"meta-p" :mode "Listener")
    334 
    335335(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Listener")
    336336(bind-key "Next Interactive Input" #k"meta-n" :mode "Listener")
     
    441441(bind-key "Open Line" #k"Control-o")
    442442(bind-key "New Line" #k"return")
     443(bind-key "New Line" #k"shift-return")
    443444
    444445(bind-key "Transpose Words" #k"meta-t")
  • release/1.3/source/cocoa-ide/hemlock/src/lispmode.lisp

    r11747 r11927  
    511511  false otherwise.  If Forwardp is true, we use the next character, otherwise
    512512  we use the previous."
    513   (multiple-value-bind (region line)
    514                        (find-ignore-region mark forwardp)
    515     (and line (not region))))
     513  (if (and (not forwardp)
     514           (null (previous-character mark)))
     515    t                         ;beginning of buffer always a valid spot
     516    (multiple-value-bind (region line)
     517        (find-ignore-region mark forwardp)
     518      (and line (not region)))))
    516519
    517520
     
    856859(defindent "do-headers-lines" 1)
    857860(defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill.
     861(defindent "modifying-buffer" 1)
    858862
    859863;;; Common Lisp forms.
  • release/1.3/source/cocoa-ide/hemlock/src/listener.lisp

    r8428 r11927  
    478478        (cond ((eql (next-character point) #\()
    479479               (with-mark ((m point))
    480                  (if (list-offset m 1)
     480                 (if (form-offset m 1)
    481481                   (eval-region (region point m)))))
    482482              ((eql (previous-character point) #\))
    483483               (with-mark ((m point))
    484                  (if (list-offset m -1)
    485                    (eval-region (region m point))))))))))
    486            
     484                 (if (form-offset m -1)
     485                   (eval-region (region m point)))))
     486              (t
     487               (with-mark ((start point)
     488                           (end point))
     489                 (when (mark-symbol start end)
     490                   (eval-region (region start end))))))))))
     491
    487492(defcommand "Editor Re-evaluate Defvar" (p)
    488493  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
  • release/1.3/source/cocoa-ide/ide-contents/Resources/English.lproj/MainMenu.nib/classes.nib

    r9636 r11927  
    2929                                <key>compileBuffer</key>
    3030                                <string>id</string>
     31                                <key>compileFile</key>
     32                                <string>id</string>
    3133                                <key>continue</key>
    3234                                <string>id</string>
     
    4244                                <string>id</string>
    4345                                <key>loadBuffer</key>
     46                                <string>id</string>
     47                                <key>loadFile</key>
    4448                                <string>id</string>
    4549                                <key>newListener</key>
  • release/1.3/source/cocoa-ide/ide-contents/Resources/English.lproj/MainMenu.nib/info.nib

    r9772 r11927  
    44<dict>
    55        <key>IBFramework Version</key>
    6         <string>629</string>
     6        <string>677</string>
    77        <key>IBOldestOS</key>
    88        <integer>5</integer>
    99        <key>IBOpenObjects</key>
    1010        <array>
    11                 <integer>24</integer>
     11                <integer>29</integer>
    1212        </array>
    1313        <key>IBSystem Version</key>
    14         <string>9D34</string>
     14        <string>9G55</string>
    1515        <key>targetFramework</key>
    1616        <string>IBCocoaFramework</string>
  • release/1.3/source/compiler/PPC/ppc-lap.lisp

    r10981 r11927  
    254254                 (pos (position label opvals)))
    255255            (unless pos
    256               (error "Bug: label ~s should be referenced by instruction ~s, but isn't."))
     256              (error "Bug: label ~s should be referenced by instruction ~s, but isn't." label insn))
    257257            (setf (svref opvals pos) diff)))))))
    258258
  • release/1.3/source/compiler/arch.lisp

    r11522 r11927  
    7171  (defconstant error-type-error 128)
    7272)
     73
    7374
    7475(defconstant error-fpu-exception-double 1024)   ; FPU exception, binary double-float op
     
    192193  simple-array-char-3d
    193194
     195  ;;
     196  vector-t
     197  bit-vector
     198  vector-s8
     199  vector-u8
     200  vector-s16
     201  vector-u16
     202  vector-s32
     203  vector-u32
     204  vector-s64
     205  vector-u64
     206  vector-fixnum
     207  vector-single-float
     208  vector-double-float
     209 
    194210  ;; Sentinel
    195211  unused-max-type-error
  • release/1.3/source/compiler/optimizers.lisp

    r11921 r11927  
    22772277        (t call)))
    22782278
    2279 (define-compiler-macro coerce (&whole call thing type)
    2280   (if (quoted-form-p type)
    2281     (setq type (cadr type)))
    2282   (if (ignore-errors (subtypep type 'single-float))
    2283     `(float ,thing 0.0f0)
    2284     (if (ignore-errors (subtypep type 'double-float))
    2285       `(float ,thing 0.0d0)
    2286       call)))
     2279(define-compiler-macro coerce (&whole call &environment env thing type)
     2280  (cond ((constantp type)
     2281         (if (quoted-form-p type)
     2282           (setq type (cadr type)))
     2283         (if (ignore-errors (subtypep type 'single-float))
     2284           `(float ,thing 0.0f0)
     2285           (if (ignore-errors (subtypep type 'double-float))
     2286             `(float ,thing 0.0d0)
     2287             (let* ((ctype (specifier-type-if-known type env))
     2288                    (simple nil)
     2289                    (extra nil))
     2290               (if (and (typep ctype 'array-ctype)
     2291                        (equal (array-ctype-dimensions ctype) '(*)))
     2292                 (if (eq (array-ctype-specialized-element-type ctype)
     2293                         (specifier-type 'character))
     2294                   (setq simple '%coerce-to-string)
     2295                   (if (and (eq *host-backend* *target-backend*)
     2296                            (array-ctype-typecode ctype))
     2297                     (setq simple '%coerce-to-vector
     2298                           extra (list (array-ctype-typecode ctype)))))
     2299                 (if (eq ctype (specifier-type 'list))
     2300                   (setq simple '%coerce-to-list)))
     2301               (if simple
     2302                 (let* ((temp (gensym)))
     2303                   `(let* ((,temp ,thing))
     2304                     (if (typep ,temp ',(type-specifier ctype))
     2305                       ,temp
     2306                       (,simple ,temp ,@extra))))
     2307               call)))))
     2308        (t call)))
    22872309
    22882310(define-compiler-macro equal (&whole call x y &environment env)
  • release/1.3/source/level-0/X86/X8632

    • Property svn:ignore
      •  

        old new  
        33*.wx32fsl
        44*.fx32fsl
         5*.sx32fsl
  • release/1.3/source/level-0/l0-array.lisp

    r10777 r11927  
    524524        (multiple-value-bind (data offset)
    525525                             (%array-header-data-and-offset v)
     526          (unless (typep i 'fixnum)
     527            (report-bad-arg i 'fixnum))
     528          (unless (and (typep i 'fixnum)
     529                       (>= (the fixnum i) 0)
     530                       (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell))))
     531            (if (not (typep i 'fixnum))
     532              (report-bad-arg i 'fixnum)
     533              (%err-disp $XARROOB i v)))
    526534          (uvref data (+ offset i)))
    527535        (if (= typecode target::subtag-arrayH)
     
    537545        (multiple-value-bind (data offset)
    538546                             (%array-header-data-and-offset v)
     547          (unless (and (typep i 'fixnum)
     548                       (>= (the fixnum i) 0)
     549                       (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell))))
     550            (if (not (typep i 'fixnum))
     551              (report-bad-arg i 'fixnum)
     552              (%err-disp $XARROOB i v)))
    539553          (setf (uvref data (+ offset i)) new))
    540554        (if (= typecode target::subtag-arrayH)
  • release/1.3/source/level-0/l0-cfm-support.lisp

    r11606 r11927  
    140140
    141141(defun soname-ptr-from-link-map (map)
    142   (with-macptrs ((dyn-strings)
    143                  (dynamic-entries (pref map :link_map.l_ld)))
    144     (let* ((soname-offset nil))
    145       ;; Walk over the entries in the file's dynamic segment; the
    146       ;; last such entry will have a tag of #$DT_NULL.  Note the
    147       ;; (loaded,on Linux; relative to link_map.l_addr on FreeBSD)
    148       ;; address of the dynamic string table and the offset of the
    149       ;; #$DT_SONAME string in that string table.
    150       ;; Actually, the above isn't quite right; there seem to
    151       ;; be cases (involving vDSO) where the address of a library's
    152       ;; dynamic string table is expressed as an offset relative
    153       ;; to link_map.l_addr as well.
    154       (loop
    155           (case #+32-bit-target (pref dynamic-entries :<E>lf32_<D>yn.d_tag)
    156                 #+64-bit-target (pref dynamic-entries :<E>lf64_<D>yn.d_tag)
    157             (#. #$DT_NULL (return))
    158             (#. #$DT_SONAME
    159                 (setq soname-offset
    160                       #+32-bit-target (pref dynamic-entries
    161                                            :<E>lf32_<D>yn.d_un.d_val)
    162                       #+64-bit-target (pref dynamic-entries
    163                                            :<E>lf64_<D>yn.d_un.d_val)))
    164             (#. #$DT_STRTAB
    165                 (%setf-macptr dyn-strings
    166                               ;; Try to guess whether we're dealing
    167                               ;; with a displacement or with an
    168                               ;; absolute address.  There may be
    169                               ;; a better way to determine this,
    170                               ;; but for now we assume that absolute
    171                               ;; addresses aren't negative and that
    172                               ;; displacements are.
    173                                (let* ((disp (%get-signed-natural
    174                                              dynamic-entries
    175                                              target::node-size)))
    176                                  #+(or freebsd-target solaris-target)
    177                                  (%inc-ptr (pref map :link_map.l_addr) disp)
    178                                  #-(or freebsd-target solaris-target)
    179                                  (let* ((udisp #+32-bit-target (pref dynamic-entries
    180                                                                      :<E>lf32_<D>yn.d_un.d_val)
    181                                                #+64-bit-target (pref dynamic-entries
    182                                                                      :<E>lf64_<D>yn.d_un.d_val)))
    183                                    (if (and (> udisp (pref map :link_map.l_addr))
    184                                             (< udisp (%ptr-to-int dynamic-entries)))
    185                                      (%int-to-ptr udisp)
    186                                      (%int-to-ptr
    187                                       (if (< disp 0)
    188                                         (+ disp (pref map :link_map.l_addr))
    189                                         disp))))))))
    190           (%setf-macptr dynamic-entries
    191                         (%inc-ptr dynamic-entries
    192                                   #+32-bit-target
    193                                   (record-length :<E>lf32_<D>yn)
    194                                   #+64-bit-target
    195                                   (record-length :<E>lf64_<D>yn))))
    196       (if (and soname-offset
    197                (not (%null-ptr-p dyn-strings)))
    198         (%inc-ptr dyn-strings soname-offset)
    199         ;; Use the full pathname of the library.
    200         (pref map :link_map.l_name)))))
     142  (let* ((path (pref map :link_map.l_name)))
     143    (if (%null-ptr-p path)
     144      (let* ((p (malloc 1)))
     145        (setf (%get-unsigned-byte p 0) 0)
     146        p)
     147      (if (eql (%get-unsigned-byte path 0) 0)
     148        path
     149        (with-macptrs ((dyn-strings)
     150                       (dynamic-entries (pref map :link_map.l_ld)))
     151          (let* ((soname-offset nil))
     152            ;; Walk over the entries in the file's dynamic segment; the
     153            ;; last such entry will have a tag of #$DT_NULL.  Note the
     154            ;; (loaded,on Linux; relative to link_map.l_addr on FreeBSD)
     155            ;; address of the dynamic string table and the offset of the
     156            ;; #$DT_SONAME string in that string table.
     157            ;; Actually, the above isn't quite right; there seem to
     158            ;; be cases (involving vDSO) where the address of a library's
     159            ;; dynamic string table is expressed as an offset relative
     160            ;; to link_map.l_addr as well.
     161            (loop
     162              (case #+32-bit-target (pref dynamic-entries :<E>lf32_<D>yn.d_tag)
     163                    #+64-bit-target (pref dynamic-entries :<E>lf64_<D>yn.d_tag)
     164                    (#. #$DT_NULL (return))
     165                    (#. #$DT_SONAME
     166                        (setq soname-offset
     167                              #+32-bit-target (pref dynamic-entries
     168                                                    :<E>lf32_<D>yn.d_un.d_val)
     169                              #+64-bit-target (pref dynamic-entries
     170                                                    :<E>lf64_<D>yn.d_un.d_val)))
     171                    (#. #$DT_STRTAB
     172                        (%setf-macptr dyn-strings
     173                                      ;; Try to guess whether we're dealing
     174                                      ;; with a displacement or with an
     175                                      ;; absolute address.  There may be
     176                                      ;; a better way to determine this,
     177                                      ;; but for now we assume that absolute
     178                                      ;; addresses aren't negative and that
     179                                      ;; displacements are.
     180                                      (let* ((disp (%get-signed-natural
     181                                                    dynamic-entries
     182                                                    target::node-size)))
     183                                        #+(or freebsd-target solaris-target)
     184                                        (%inc-ptr (pref map :link_map.l_addr) disp)
     185                                        #-(or freebsd-target solaris-target)
     186                                        (let* ((udisp #+32-bit-target (pref dynamic-entries
     187                                                                            :<E>lf32_<D>yn.d_un.d_val)
     188                                                      #+64-bit-target (pref dynamic-entries
     189                                                                            :<E>lf64_<D>yn.d_un.d_val)))
     190                                          (if (and (> udisp (pref map :link_map.l_addr))
     191                                                   (< udisp (%ptr-to-int dynamic-entries)))
     192                                            (%int-to-ptr udisp)
     193                                            (%int-to-ptr
     194                                             (if (< disp 0)
     195                                               (+ disp (pref map :link_map.l_addr))
     196                                               disp))))))))
     197              (%setf-macptr dynamic-entries
     198                            (%inc-ptr dynamic-entries
     199                                      #+32-bit-target
     200                                      (record-length :<E>lf32_<D>yn)
     201                                      #+64-bit-target
     202                                      (record-length :<E>lf64_<D>yn))))
     203            (if (and soname-offset
     204                     (not (%null-ptr-p dyn-strings)))
     205              (%inc-ptr dyn-strings soname-offset)
     206              ;; Use the full pathname of the library.
     207             (pref map :link_map.l_name))))))))
    201208
    202209(defun shared-library-at (base)
     
    852859(defun last-dot-pos (name)
    853860  (do* ((i (1- (length name)) (1- i))
    854        (trailing-digits nil))
    855        ((<= i 0))
     861        (default i)
     862        (trailing-digits nil))
     863       ((<= i 0) default)
    856864    (declare (fixnum i))
    857865    (let* ((code (%scharcode name i)))
     
    862870        (if (= code (char-code #\.))
    863871          (return (if trailing-digits i))
    864           (return nil))))))
     872          (return default))))))
    865873 
    866874;;; It's assumed that the set of libraries that the OS has open
  • release/1.3/source/level-1/l1-error-system.lisp

    r11856 r11927  
    9191             (with-slots (address write-p) c
    9292               (format s "Fault during ~a memory address #x~x" (if write-p "write to" "read of") address)))))
    93  
     93
     94(define-condition invalid-memory-operation (storage-condition)
     95  ()
     96  (:report (lambda (c s)
     97             (declare (ignore c))
     98             (format s "Invalid memory operation."))))
     99
     100
    94101(define-condition type-error (error)
    95102  ((datum :initarg :datum)
     
    11941201    (simple-array double-float (* * *))
    11951202    (simple-array char (* * *))
    1196    
     1203
     1204    (vector t)
     1205    bit-vector
     1206    (vector (signed-byte 8))
     1207    (vector (unsigned-byte 8))
     1208    (vector (signed-byte 16))
     1209    (vector (unsigned-byte 16))
     1210    (vector (signed-byte 32))
     1211    (vector (unsigned-byte 32))
     1212    (vector (signed-byte 64))
     1213    (vector (unsigned-byte 64))
     1214    (vector fixnum)
     1215    (vector single-float)
     1216    (vector double-float)
     1217
    11971218    ))
    11981219
  • release/1.3/source/level-1/x86-trap-support.lisp

    r11342 r11927  
    430430                        :void))))
    431431          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
    432            (%error (make-condition 'invalid-memory-access
    433                     :address addr
    434                     :write-p (not (zerop code)))
    435                    ()
    436                    frame-ptr))))
     432           (if (= code -1)
     433             (%error (make-condition 'invalid-memory-operation)
     434                     ()
     435                     frame-ptr)
     436             (%error (make-condition 'invalid-memory-access
     437                                     :address addr
     438                                     :write-p (not (zerop code)))
     439                     ()
     440                     frame-ptr)))))
    437441  0)
    438442
  • release/1.3/source/lib/misc.lisp

    r11527 r11927  
    695695                       (return-from get-answer (list (nth value list))))))))))))
    696696
     697(defvar *choose-file-dialog-hook* nil "for GUIs")
     698
    697699;;; There should ideally be some way to override the UI (such as
    698700;;; it is ...) here.
     
    701703;;;   b) should do more sanity-checking
    702704(defun choose-file-dialog (&key file-types (prompt "File name:"))
    703   (%choose-file-dialog t prompt file-types))
     705  (let* ((hook *choose-file-dialog-hook*))
     706    (if hook
     707      (funcall hook t prompt file-types)
     708      (%choose-file-dialog t prompt file-types))))
    704709
    705710(defun choose-new-file-dialog (&key prompt)
    706   (%choose-file-dialog nil prompt nil))
     711  (let* ((hook *choose-file-dialog-hook*))
     712    (if hook
     713      (funcall hook nil prompt nil)
     714      (%choose-file-dialog nil prompt nil))))
    707715
    708716(defun %choose-file-dialog (must-exist prompt file-types)
  • release/1.3/source/lib/sequences.lisp

    r11545 r11927  
    845845        (t (error "~S can't be coerced to type ~S." object output-type-spec))))))
    846846
     847(defun %coerce-to-string (seq)
     848   (let* ((len (length seq))
     849          (string (make-string len)))
     850     (declare (fixnum len) (simple-base-string string))
     851     (if (typep seq 'list)
     852       (do* ((l seq (cdr l))
     853             (i 0 (1+ i)))
     854            ((null l) string)
     855         (declare (list l) ; we know that it's a proper list because LENGTH won
     856                  (fixnum i))
     857         (setf (schar string i) (car l)))
     858       (dotimes (i len string)
     859         (setf (schar string i) (aref seq i))))))
     860
     861(defun %coerce-to-vector (seq subtype)
     862   (let* ((len (length seq))
     863          (vector (%alloc-misc len subtype)))
     864     (declare (fixnum len) (type (simple-array * (*)) vector))
     865     (if (typep seq 'list)
     866       (do* ((l seq (cdr l))
     867             (i 0 (1+ i)))
     868            ((null l) vector)
     869         (declare (list l) ; we know that it's a proper list because LENGTH won
     870                  (fixnum i))
     871         (setf (uvref vector i) (car l)))
     872       (dotimes (i len vector)
     873         (setf (uvref vector i) (aref seq i))))))
     874
     875(defun %coerce-to-list (seq)
     876  (if (typep seq 'list)
     877    seq
     878    (collect ((result))
     879      (dotimes (i (length seq) (result))
     880        (result (aref seq i))))))
     881
     882
     883
    847884
    848885(defun coerce-to-complex (object  output-type-spec)
  • release/1.3/source/lisp-kernel/errors.s

    r8579 r11927  
    151151        def_type_error(simple_array_double_float_3d)
    152152        def_type_error(simple_array_char_3d)
     153        def_type_error(vector_t)
     154        def_type_error(bit_vector)
     155        def_type_error(vector_s8)
     156        def_type_error(vector_u8)
     157        def_type_error(vector_s16)
     158        def_type_error(vector_u16)
     159        def_type_error(vector_s32)
     160        def_type_error(vector_u32)
     161        def_type_error(vector_s64)
     162        def_type_error(vector_u64)
     163        def_type_error(vector_fixnum)
     164        def_type_error(vector_single_float)
     165        def_type_error(vector_double_float)
     166       
    153167       
    154168       
  • release/1.3/source/lisp-kernel/lisp-debug.c

    r11624 r11927  
    875875#endif
    876876#ifdef WINDOWS
    877           0 /* XXX: get from somewhere */
     877          *(xpMXCSRptr(xp))
    878878#endif
    879879          );
  • release/1.3/source/lisp-kernel/x86-exceptions.c

    r11814 r11927  
    866866#endif
    867867#endif
    868 
    869 
    870   if (addr && (addr == tcr->safe_ref_address)) {
    871     xpGPR(xp,Iimm0) = 0;
    872     xpPC(xp) = xpGPR(xp,Ira0);
    873     return true;
    874   } else {
    875     protected_area *a = find_protected_area(addr);
    876     protection_handler *handler;
    877 
    878     if (a) {
    879       handler = protection_handlers[a->why];
    880       return handler(xp, a, addr);
     868  Boolean valid = IS_PAGE_FAULT(info,xp);
     869
     870  if (valid) {
     871    if (addr && (addr == tcr->safe_ref_address)) {
     872      xpGPR(xp,Iimm0) = 0;
     873      xpPC(xp) = xpGPR(xp,Ira0);
     874      return true;
    881875    } else {
    882       if ((addr >= readonly_area->low) &&
    883           (addr < readonly_area->active)) {
    884         UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)),
    885                         page_size);
    886         return true;
     876      protected_area *a = find_protected_area(addr);
     877      protection_handler *handler;
     878     
     879      if (a) {
     880        handler = protection_handlers[a->why];
     881        return handler(xp, a, addr);
     882      } else {
     883        if ((addr >= readonly_area->low) &&
     884            (addr < readonly_area->active)) {
     885          UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)),
     886                          page_size);
     887          return true;
     888        }
    887889      }
    888890    }
     
    894896      (header_subtag(header_of(cmain)) == subtag_macptr)) {
    895897      xcf = create_exception_callback_frame(xp, tcr);
    896       callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, is_write_fault(xp,info), (natural)addr, 0);
     898      callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, valid ? is_write_fault(xp,info) : (natural)-1, valid ? (natural)addr : 0, 0);
    897899    }
    898900  }
     
    18211823}
    18221824
     1825static
     1826DWORD mxcsr_bit_to_fpe_code[] = {
     1827  EXCEPTION_FLT_INVALID_OPERATION, /* ie */
     1828  0,                            /* de */
     1829  EXCEPTION_FLT_DIVIDE_BY_ZERO, /* ze */
     1830  EXCEPTION_FLT_OVERFLOW,       /* oe */
     1831  EXCEPTION_FLT_UNDERFLOW,      /* ue */
     1832  EXCEPTION_FLT_INEXACT_RESULT  /* pe */
     1833};
     1834
     1835#ifndef STATUS_FLOAT_MULTIPLE_FAULTS
     1836#define STATUS_FLOAT_MULTIPLE_FAULTS 0xc00002b4
     1837#endif
     1838
     1839#ifndef STATUS_FLOAT_MULTIPLE_TRAPS
     1840#define  STATUS_FLOAT_MULTIPLE_TRAPS 0xc00002b5
     1841#endif
     1842
    18231843int
    1824 map_windows_exception_code_to_posix_signal(DWORD code)
     1844map_windows_exception_code_to_posix_signal(DWORD code, siginfo_t *info, ExceptionInformation *context)
    18251845{
    18261846  switch (code) {
     1847#ifdef WIN_32
     1848  case STATUS_FLOAT_MULTIPLE_FAULTS:
     1849  case STATUS_FLOAT_MULTIPLE_TRAPS:
     1850    {
     1851      int xbit, maskbit;
     1852      DWORD mxcsr = *(xpMXCSRptr(context));
     1853
     1854      for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) {
     1855        if ((mxcsr & (1 << xbit)) &&
     1856            !(mxcsr & (1 << maskbit))) {
     1857          info->ExceptionCode = mxcsr_bit_to_fpe_code[xbit];
     1858          break;
     1859        }
     1860      }
     1861    }
     1862    return SIGFPE;
     1863#endif
     1864     
    18271865  case EXCEPTION_ACCESS_VIOLATION:
    18281866    return SIGSEGV;
     
    18601898  wait_for_exception_lock_in_handler(tcr, context, &xframes);
    18611899
    1862   signal_number = map_windows_exception_code_to_posix_signal(code);
     1900  signal_number = map_windows_exception_code_to_posix_signal(code, info, context);
    18631901 
    18641902  if (!handle_exception(signal_number, info, context, tcr, old_valence)) {
  • release/1.3/source/lisp-kernel/x86-exceptions.h

    r11565 r11927  
    9494#define xpPC(x) xpGPR(x,Iip)
    9595#define eflags_register(xp) xp->EFlags
     96#define xpMXCSRptr(x) (DWORD *)(&(x->MxCsr))
    9697#else
    9798#define xpGPRvector(x) ((DWORD *)(&(x)->Edi))
     
    101102#define xpFPRvector(x) ((natural *)(&(x->ExtendedRegisters[10*16])))
    102103#define xpMMXreg(x,n)  (*((u64_t *)(&(x->FloatSave.RegisterArea[10*(n)]))))
     104#define xpMXCSRptr(x) (DWORD *)(&(x->ExtendedRegisters[24]))
    103105#endif
    104106#endif
     
    167169#ifdef LINUX
    168170#define SIGNUM_FOR_INTN_TRAP SIGSEGV
    169 #define IS_MAYBE_INT_TRAP(info,xp) (((info->si_code) &0x7f) == 0)
     171#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,REG_TRAPNO)==0xd)&&((xpGPR(xp,REG_ERR)&7)==2))
     172#define IS_PAGE_FAULT(info,xp) (xpGPR(xp,REG_TRAPNO)==0xe)
    170173#define SIGRETURN(context)
    171174#endif
     
    174177extern void freebsd_sigreturn(ExceptionInformation *);
    175178#define SIGNUM_FOR_INTN_TRAP SIGBUS
    176 #define IS_MAYBE_INT_TRAP(info,xp) (xp->uc_mcontext.mc_trapno == T_PROTFLT)
     179#define IS_MAYBE_INT_TRAP(info,xp) ((xp->uc_mcontext.mc_trapno == T_PROTFLT) && ((xp->uc_mcontext.mc_err & 7) == 2))
     180#define IS_PAGE_FAULT(info,xp) (xp->uc_mcontext.mc_trapno == T_PAGEFLT)
    177181#define SIGRETURN(context) freebsd_sigreturn(context)
    178182#endif
     
    180184#ifdef DARWIN
    181185#define SIGNUM_FOR_INTN_TRAP SIGSEGV /* Not really, but our Mach handler fakes that */
    182 #define IS_MAYBE_INT_TRAP(info,xp) (info->si_code == EXC_I386_GPFLT)
     186#define IS_MAYBE_INT_TRAP(info,xp) ((UC_MCONTEXT(xp)->__es.trapno == 0xd) && (((UC_MCONTEXT(xp)->__es.err)&7)==2))
     187#define IS_PAGE_FAULT(info,xp) (UC_MCONTEXT(xp)->__es.trapno == 0xe)
    183188/* The x86 version of sigreturn just needs the context argument; the
    184189   hidden, magic "flavor" argument that sigtramp uses is ignored. */
     
    190195#ifdef X8664
    191196#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,REG_TRAPNO)==0xd)&&((xpGPR(xp,REG_ERR)&7)==2))
     197#define IS_PAGE_FAULT(info,xp) (xpGPR(xp,REG_TRAPNO)==0xe)
    192198#else
    193199#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,TRAPNO)==0xd)&&((xpGPR(xp,ERR)&7)==2))
     200#define IS_PAGE_FAULT(info,xp) (xpGPR(xp,TRAPNO)==0xe)
    194201#endif
    195202#define SIGRETURN(context) setcontext(context)
     
    202209   (info->ExceptionInformation[0]==0) &&                       \
    203210   (info->ExceptionInformation[1]==(ULONG_PTR)(-1L)))
     211#define IS_PAGE_FAULT(info,xp) (1)
    204212#define SIGRETURN(context)      /* for now */
    205213#endif
Note: See TracChangeset for help on using the changeset viewer.