Changeset 7287


Ignore:
Timestamp:
Sep 24, 2007, 6:40:52 PM (12 years ago)
Author:
rme
Message:

Merged trunk changes r7244:7286

Location:
branches/ia32
Files:
19 edited

Legend:

Unmodified
Added
Removed
  • branches/ia32/ChangeLog

    r7244 r7287  
     12007-09-24 06:10  gb
     2
     3        * lisp-kernel/x86-exceptions.c: Missing #ifdef DARWIN in
     4        arbstack_signal_handler; not used on Darwin.
     5
     62007-09-23 21:11  gb
     7
     8        * lisp-kernel/: lisp-debug.c, lisp-exceptions.h, x86-exceptions.c,
     9        x86-exceptions.h: Don't use sigaltstack on any x86-64 platform:
     10        even if it works, it makes it harder to deal with exceptions in
     11        foreign code (we've often gotten segfaults from running out of
     12        space on the alt stack, the mechanism isn't reentrant, etc.)
     13       
     14        Try to report cases where the kernel debugger is entered due to an
     15        exception in foreign code.  Todo: make it less tempting to use (L)
     16        in that case, maybe try to make backtrace find saved_rbp from tcr
     17        on x86-64, etc.
     18
     192007-09-23 21:10  gb
     20
     21        * level-1/l1-application.lisp: APPLICATION-VERSION-STRING (which
     22        probably was used to support "get info", back in the day) is just
     23        LISP-IMPLEMENTATION-VERSION.
     24
     252007-09-23 09:12  gb
     26
     27        * xdump/xfasload.lisp: Handle saving svn revision as string or
     28        fixnum.
     29
     302007-09-23 09:11  gb
     31
     32        * lib/misc.lisp: Try to use "svnversion" to get svn version info in
     33        LOCAL-SVN-REVISION.
     34
     352007-09-22 23:13  gb
     36
     37        * xdump/xfasload.lisp: Set *openmcl-svn-revision* to the value of
     38        (LOCAL-SVN-REVISION) when writing the bootstrapping image; this
     39        will show up in the Welcome banner and LISP-IMPLEMENTATION-VERSION.
     40          May want to tweak this some more, but it may make it easier to
     41        determine what you're running relative to what's in SVN/CVS.
     42
     432007-09-22 23:12  gb
     44
     45        * level-1/version.lisp: Replace *OPENMCL-SUFFIX* (the thing which
     46        had the date in it) with *OPENMCL-SVN-REVISION*, which is defvar'ed
     47        to NIL here.  (It may be set early in the cold load or via the
     48        xloader.)
     49
     502007-09-22 23:11  gb
     51
     52        * lib/pathnames.lisp: Treat NIL and :UNSPECIFIC name/type
     53        components in the pattern consistently in %FILE*=.
     54
     552007-09-22 23:10  gb
     56
     57        * lib/misc.lisp: LOCAL-SVN-REVISION tries to determine the (local)
     58        svn revision, by looking for a .svnrev file (used in the svn->cvs
     59        synching process) or by parsing "svn info" output.
     60
     612007-09-21 12:10  gb
     62
     63        * cocoa-ide/cocoa-editor.lisp: Rename "cache" to "mirror" in
     64        hemlock-text-storage.  This clarifies the purpose of the slot and
     65        avoids confusion with buffer caches, which are completely
     66        different.
     67
     682007-09-20 21:10  gb
     69
     70        * level-1/linux-files.lisp: Make the pipe streams created by
     71        RUN-PROGRAM be basic streams
     72
     732007-09-19 15:10  gb
     74
     75        * lib/macros.lisp: Prevent unused gensym warnings in
     76        with-accessors.  Same fix that Gary Palter did to with-slots.
     77
     782007-09-19 02:11  gb
     79
     80        * lib/backtrace-lds.lisp: FRAME-REQUIRED-ARGS: try to make better.
     81        This is only used by SLIME; it was once used for frame restarting.
     82        Try to make the result reasonable in the SLIME case.
     83
     842007-09-19 02:10  gb
     85
     86        * lib/arglist.lisp: ARGLIST-FROM-MAP: don't be afraid to say
     87        &LEXPR.  ARG-NAMES-FROM-MAP: &rest in map before &keys now.
     88
     892007-09-18 21:10  gb
     90
     91        * lib/macros.lisp: In WITH-SLOTS, if there are bindings, declare
     92        the gensym'ed instance symbol IGNORABLE just in case none of the
     93        symbol macros are actuall used.
     94
     952007-09-18 05:10  gb
     96
     97        * level-0/l0-numbers.lisp: Typo in constant again.
     98
     992007-09-17 21:10  gb
     100
     101        * level-1/sysutils.lisp: Return all three values from
     102        CCL::PRINT-DEFERRED-WARNINGS
     103
    11042007-09-17 06:10  gb
    2105
  • branches/ia32/cocoa-ide/OpenMCL.app/Contents/MacOS

    • Property svn:ignore
      •  

        old new  
        1 dx86cl64
         1*
  • branches/ia32/cocoa-ide/cocoa-editor.lisp

    r7244 r7287  
    363363     (hemlock-string :foreign-type :id)
    364364     (edit-count :foreign-type :int)
    365      (cache :foreign-type :id)
     365     (mirror :foreign-type :id)
    366366     (styles :foreign-type :id)
    367367     (selection-set-by-search :foreign-type :<BOOL>))
     
    401401                                                                  (extra :<NSI>nteger))
    402402  (declare (ignorable extra))
    403   (let* ((cache (#/cache self))
     403  (let* ((mirror (#/mirror self))
    404404         (hemlock-string (#/hemlockString self))
    405405         (display (hemlock-buffer-string-cache hemlock-string))
     
    410410    #+debug
    411411    (#_NSLog #@"insert: pos = %ld, n = %ld" :long pos :long n)
    412     ;; We need to update the hemlock string cache here so that #/substringWithRange:
     412    ;; We need to update the hemlock string mirror here so that #/substringWithRange:
    413413    ;; will work on the hemlock buffer string.
    414414    (adjust-buffer-cache-for-insertion display pos n)
     
    417417      (ns:with-ns-range (replacerange pos 0)
    418418        (#/replaceCharactersInRange:withString:
    419          cache replacerange replacestring)))
    420     (#/setAttributes:range: cache font (ns:make-ns-range pos n))   
     419         mirror replacerange replacestring)))
     420    (#/setAttributes:range: mirror font (ns:make-ns-range pos n))   
    421421    (textstorage-note-insertion-at-position self pos n)
    422422    ;; Arguably, changecount stuff should happen via the document's NSUndoManager.
     
    433433  (ns:with-ns-range (range pos n)
    434434    ;; It seems to be necessary to call #/edited:range:changeInLength: before
    435     ;; deleting from the cached attributed string.  It's not clear whether this
     435    ;; deleting from the mirror attributed string.  It's not clear whether this
    436436    ;; is also true of insertions and modifications.
    437437    (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
    438438                                                 #$NSTextStorageEditedAttributes)
    439439                                    range (- n))
    440     (#/deleteCharactersInRange: (#/cache self) range))
     440    (#/deleteCharactersInRange: (#/mirror self) range))
    441441  (let* ((display (hemlock-buffer-string-cache (#/hemlockString self))))
    442442    (reset-buffer-cache display)
     
    454454  (declare (ignorable extra))
    455455  (let* ((hemlock-string (#/hemlockString self))
    456          (cache (#/cache self)))
     456         (mirror (#/mirror self)))
    457457    (ns:with-ns-range (range pos n)
    458458      (#/replaceCharactersInRange:withString:
    459        cache range (#/substringWithRange: hemlock-string range))
     459       mirror range (#/substringWithRange: hemlock-string range))
    460460      (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
    461461                                                   #$NSTextStorageEditedAttributes) range 0)))
     
    471471                                                                   (fontnum :<NSI>nteger))
    472472  (ns:with-ns-range (range pos n)
    473     (#/setAttributes:range: (#/cache self) (#/objectAtIndex: (#/styles self) fontnum) range)
     473    (#/setAttributes:range: (#/mirror self) (#/objectAtIndex: (#/styles self) fontnum) range)
    474474    (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes range 0)))
    475475
     
    516516  (slot-value self 'string))
    517517
    518 (objc:defmethod #/cache ((self hemlock-text-storage))
    519   (slot-value self 'cache))
     518(objc:defmethod #/mirror ((self hemlock-text-storage))
     519  (slot-value self 'mirror))
    520520
    521521(objc:defmethod #/hemlockString ((self hemlock-text-storage))
     
    540540  (let* ((newself (#/init self))
    541541         (styles (make-editor-style-map))
    542          (cache (#/retain (make-instance ns:ns-mutable-attributed-string
     542         (mirror (#/retain (make-instance ns:ns-mutable-attributed-string
    543543                                   :with-string s
    544544                                   :attributes (#/objectAtIndex: styles 0)))))
     
    546546    (setf (slot-value newself 'styles) styles)
    547547    (setf (slot-value newself 'hemlock-string) s)
    548     (setf (slot-value newself 'cache) cache)
    549     (setf (slot-value newself 'string) (#/retain (#/string cache)))
     548    (setf (slot-value newself 'mirror) mirror)
     549    (setf (slot-value newself 'string) (#/retain (#/string mirror)))
    550550    newself))
    551551
    552552;;; Should generally only be called after open/revert.
    553 (objc:defmethod (#/updateCache :void) ((self hemlock-text-storage))
    554   (with-slots (hemlock-string cache styles) self
    555     (#/replaceCharactersInRange:withString: cache (ns:make-ns-range 0 (#/length cache)) hemlock-string)
    556     (#/setAttributes:range: cache (#/objectAtIndex: styles 0) (ns:make-ns-range 0 (#/length cache)))))
     553(objc:defmethod (#/updateMirror :void) ((self hemlock-text-storage))
     554  (with-slots (hemlock-string mirror styles) self
     555    (#/replaceCharactersInRange:withString: mirror (ns:make-ns-range 0 (#/length mirror)) hemlock-string)
     556    (#/setAttributes:range: mirror (#/objectAtIndex: styles 0) (ns:make-ns-range 0 (#/length mirror)))))
    557557
    558558;;; This is the only thing that's actually called to create a
     
    573573  #+debug
    574574  (#_NSLog #@"Attributes at index: %lu storage %@" :<NSUI>nteger index :id self)
    575   (with-slots (cache styles) self
    576     (when (>= index (#/length cache))
    577       (#_NSLog #@"Attributes at index: %lu  edit-count: %d cache: %@ layout: %@" :<NSUI>nteger index ::unsigned (slot-value self 'edit-count) :id cache :id (#/objectAtIndex: (#/layoutManagers self) 0))
     575  (with-slots (mirror styles) self
     576    (when (>= index (#/length mirror))
     577      (#_NSLog #@"Attributes at index: %lu  edit-count: %d mirror: %@ layout: %@" :<NSUI>nteger index ::unsigned (slot-value self 'edit-count) :id mirror :id (#/objectAtIndex: (#/layoutManagers self) 0))
    578578      (for-each-textview-using-storage self
    579579                                       (lambda (tv)
     
    582582                                           (process-interrupt proc #'dbg))))
    583583      (dbg))
    584     (let* ((attrs (#/attributesAtIndex:effectiveRange: cache index rangeptr)))
     584    (let* ((attrs (#/attributesAtIndex:effectiveRange: mirror index rangeptr)))
    585585      (when (eql 0 (#/count attrs))
    586586        (#_NSLog #@"No attributes ?")
    587587        (ns:with-ns-range (r)
    588588          (#/attributesAtIndex:longestEffectiveRange:inRange:
    589            cache index r (ns:make-ns-range 0 (#/length cache)))
     589           mirror index r (ns:make-ns-range 0 (#/length mirror)))
    590590          (setq attrs (#/objectAtIndex: styles 0))
    591           (#/setAttributes:range: cache attrs r)))
     591          (#/setAttributes:range: mirror attrs r)))
    592592      attrs)))
    593593
     
    631631  #+debug
    632632  (#_NSLog #@"Set attributes: %@ at %d/%d" :id attributes :int (pref r :<NSR>ange.location) :int (pref r :<NSR>ange.length))
    633   (with-slots (cache) self
    634     (#/setAttributes:range: cache attributes r)
     633  (with-slots (mirror) self
     634    (#/setAttributes:range: mirror attributes r)
    635635      #+debug
    636       (#_NSLog #@"Assigned attributes = %@" :id (#/attributesAtIndex:effectiveRange: cache (pref r :<NSR>ange.location) +null-ptr+))))
     636      (#_NSLog #@"Assigned attributes = %@" :id (#/attributesAtIndex:effectiveRange: mirror (pref r :<NSR>ange.location) +null-ptr+))))
    637637
    638638(defun for-each-textview-using-storage (textstorage f)
     
    21162116                                                display
    21172117                                                (min newlen pointpos))))
    2118     (#/updateCache textstorage)
     2118    (#/updateMirror textstorage)
    21192119    (#/endEditing textstorage)
    21202120    (hi::document-set-point-position self)
     
    21812181               (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
    21822182          (reset-buffer-cache display)
    2183           (#/updateCache textstorage)
     2183          (#/updateMirror textstorage)
    21842184          (update-line-cache-for-index display 0)
    21852185          (textstorage-note-insertion-at-position
  • branches/ia32/examples/cocoa

    • Property svn:ignore set to
      *~.*
  • branches/ia32/level-0/l0-numbers.lisp

    r7244 r7287  
    17831783  (declare (type (unsigned-byte 16) high low))
    17841784  (let* ((n0
    1785           (%i* 42871
     1785          (%i* 48271
    17861786             (the  (unsigned-byte 31)
    17871787               (logior (the (unsigned-byte 31)
  • branches/ia32/level-1/l1-application.lisp

    r6970 r7287  
    183183  "Return a string which (arbitrarily) represents the application version.
    184184Default version returns OpenMCL version info."
    185   (format nil "~&~d.~d~@[.~d~]~@[-~a~]~&"
    186           *openmcl-major-version*
    187           *openmcl-minor-version*
    188           (unless (zerop *openmcl-revision*)
    189             *openmcl-revision*)
    190           *openmcl-suffix*))
     185  (lisp-implementation-version))
    191186
    192187(defmethod application-ui-operation ((a application) operation &rest args)
  • branches/ia32/level-1/linux-files.lisp

    r7244 r7287  
    698698                                  :direction :output
    699699                                  :element-type element-type
    700                                   :interactive nil)
     700                                  :interactive nil
     701                                  :basic t)
    701702                  (cons read-pipe close-in-parent)
    702703                  (cons write-pipe close-on-error)))
     
    706707                                  :direction :input
    707708                                  :element-type element-type
    708                                   :interactive nil)
     709                                  :interactive nil
     710                                  :basic t)
    709711                  (cons write-pipe close-in-parent)
    710712                  (cons read-pipe close-on-error)))
  • branches/ia32/level-1/sysutils.lisp

    r2326 r7287  
    542542              (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any))
    543543              (setq init nil))))))
    544     (values (values any harsh parent))))
     544    (values any harsh parent)))
    545545
    546546(defun print-nested-name (name-list stream)
  • branches/ia32/level-1/version.lisp

    r6959 r7287  
    2020(defparameter *openmcl-minor-version* 1)
    2121(defparameter *openmcl-revision* 0)
    22 (defparameter *openmcl-suffix* "pre-070722")
     22;;; May be set by xload-level-0
     23(defvar *openmcl-svn-revision* nil)
    2324(defparameter *openmcl-dev-level* nil)
    2425
    25 (defparameter *openmcl-version* (format nil "~d.~d~@[.~d~]~@[-~a~] (~@[~A: ~]~~A)"
     26(defparameter *openmcl-version* (format nil "~d.~d~@[.~d~]~@[-r~a~] (~@[~A: ~]~~A)"
    2627                                        *openmcl-major-version*
    2728                                        *openmcl-minor-version*
    2829                                        (unless (zerop *openmcl-revision*)
    2930                                          *openmcl-revision*)
    30                                         *openmcl-suffix*
     31                                        *openmcl-svn-revision*
    3132                                        *openmcl-dev-level*))
    3233
    3334
     35
     36
    3437;;; end
  • branches/ia32/lib/arglist.lisp

    r7244 r7287  
    166166    (declare (ignore optinit))
    167167    (if lexprp
    168       (values nil nil)
    169       (let ((map (car (function-symbol-map lfun))))
    170         (if map
    171           (let ((total (+ nreq nopt (if restp 1 0) (or nkeys 0)))
    172                 (idx (- (length map) nclosed))
    173                 (res nil))
    174             (if (%izerop total)
    175               (values nil t)
    176               (progn
    177                 (dotimes (x nreq)
    178                   (declare (fixnum x))
    179                   (push (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x)) res))
    180                 (when (neq nopt 0)
    181                   (push '&optional res)
    182                   (dotimes (x (the fixnum nopt))
    183                     (push (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)) res)))
    184 
    185                 (when restp
    186                   (push '&rest res)
    187                   (when nkeys
    188                     (when (> idx nkeys) (decf idx nkeys)))
    189                   (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res))                  (when nkeys
    190                   (push '&key res)
    191                   (let ((keyvect (lfun-keyvect lfun)))
    192                     (dotimes (i (length keyvect))
    193                       (push (elt keyvect i) res))))
    194                 (when allow-other-keys
    195                   (push '&allow-other-keys res))))
    196             (values (nreverse res) t))
    197           (values nil (zerop ncells)))))))
     168      (setq restp t))
     169    (let ((map (car (function-symbol-map lfun))))
     170      (if map
     171        (let ((total (+ nreq nopt (if restp 1 0) (or nkeys 0)))
     172              (idx (- (length map) nclosed))
     173              (res nil))
     174          (if (%izerop total)
     175            (values nil t)
     176            (progn
     177              (dotimes (x nreq)
     178                (declare (fixnum x))
     179                (push (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x)) res))
     180              (when (neq nopt 0)
     181                (push '&optional res)
     182                (dotimes (x (the fixnum nopt))
     183                  (push (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)) res)))
     184
     185              (when restp
     186                (push (if lexprp '&lexpr '&rest) res)
     187                (when nkeys
     188                  (when (> idx nkeys) (decf idx nkeys)))
     189                (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res))                  (when nkeys
     190                (push '&key res)
     191                (let ((keyvect (lfun-keyvect lfun)))
     192                  (dotimes (i (length keyvect))
     193                    (push (elt keyvect i) res))))
     194              (when allow-other-keys
     195                (push '&allow-other-keys res))))
     196          (values (nreverse res) t))
     197        (values nil (zerop ncells))))))
    198198
    199199(defun arg-names-from-map (lfun pc)
     
    219219                  (dotimes (x (the fixnum nopt))
    220220                    (opt (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)))))
    221                 (when nkeys
    222                   (dotimes (i (the fixnum nkeys))
    223                     (keys (if (> idx 0) (elt map (decf idx)) (make-arg "KEY" i)))))
    224221                (when (or restp lexprp)
    225                   (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest)))))))
     222                  (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest)))                (when nkeys
     223                                                                                              (dotimes (i (the fixnum nkeys))
     224                    (keys (if (> idx 0) (elt map (decf idx)) (make-arg "KEY" i)))))))))
    226225        (values (not (null map)) (req) (opt) rest (keys))))))
    227226             
  • branches/ia32/lib/backtrace-lds.lisp

    r4535 r7287  
    3030
    3131
    32 ;;; Returns five values: (ARGS TYPES NAMES COUNT NCLOSED)
    33 ;;; ARGS is a list of the args supplied to the function
    34 ;;; TYPES is a list of the types of the args.
    35 ;;; NAMES is a list of the names of the args.
    36 ;;; TYPES & NAMES will hae entries only for closed-over,
    37 ;;;       required, & optional args.
    38 ;;; COUNT is the number of known-correct elements of ARGS, or T if
    39 ;;;       they're all correct.
    40 ;;; ARGS will be filled with NIL up to the number of required args to lfun
    41 ;;; NCLOSED is the number of closed-over values that are in the prefix of ARGS
    42 ;;;       If COUNT < NCLOSED, it is not safe to restart the function.
     32;;; Returns three values: (ARG-VALUES TYPES NAMES), solely for the benefit
     33;;; of the FRAME-ARGUMENTS function in SLIME's swank-openmcl.lisp.
     34;;; ARG-VALUES is a list of the values of the args supplied to the function
     35;;; TYPES is a list of (for bad historical reasons) strings .describing
     36;;;   whether they're "required", "optional", etc.  SLIME only really
     37;;;   cares about whether this is equal to "keyword" or not.
     38;;; NAMES is a list of symbols which name the args.
    4339(defun frame-supplied-args (frame lfun pc child context)
    4440  (declare (ignore child))
    45   (multiple-value-bind (req opt restp keys allow-other-keys optinit lexprp ncells nclosed)
    46       (function-args lfun)
    47     (declare (ignore allow-other-keys lexprp ncells))
    48     (multiple-value-bind (child-vsp vsp) (vsp-limits frame context)
    49       (decf vsp)
    50       (let* ((frame-size (- vsp child-vsp))
    51              (res nil)
    52              (types nil)
    53              (names nil))
    54         (flet ((push-type&name (cellno)
    55                  (multiple-value-bind (type name) (find-local-name cellno lfun pc)
    56                    (push type types)
    57                    (push name names))))
    58           (declare (dynamic-extent #'push-type&name))
    59           (if (or
    60                (<= frame-size 0))
    61             ;; Can't parse the frame, but all but the last 3 args are on the stack
    62             (let* ((nargs (+ nclosed req))
    63                    (vstack-args (max 0 (min frame-size (- nargs 3)))))
    64               (dotimes (i vstack-args)
    65                 (declare (fixnum i))
    66                 (push (access-lisp-data vsp) res)
    67                 (push-type&name i)
    68                 (decf vsp))
    69               (values (nreconc res (make-list (- nargs vstack-args)))
    70                       (nreverse types)
    71                       (nreverse names)
    72                       vstack-args
    73                       nclosed))
    74             ;; All args were vpushed.
    75             (let* ((might-be-rest (> frame-size (+ req opt)))
    76                    (rest (and restp might-be-rest (access-lisp-data (- vsp req opt))))
    77                    (cellno -1))
    78               (declare (fixnum cellno))
    79               (when (and keys might-be-rest (null rest))
    80                 (let ((vsp (- vsp req opt))
    81                       (keyvect (lfun-keyvect lfun))
    82                       (res nil))
    83                   (dotimes (i keys)
    84                     (declare (fixnum i))
    85                     (when (access-lisp-data (1- vsp)) ; key-supplied-p
    86                       (push (aref keyvect i) res)
    87                       (push (access-lisp-data vsp) res))
    88                     (decf vsp 2))
    89                   (setq rest (nreverse res))))
    90               (dotimes (i nclosed)
    91                 (declare (fixnum i))
    92                 (when (<= vsp child-vsp) (return))
    93                 (push (access-lisp-data vsp) res)
    94                 (push-type&name (incf cellno))
    95                 (decf vsp))
    96               (dotimes (i req)
    97                 (declare (fixnum i))
    98                 (when (<= vsp child-vsp) (return))
    99                 (push (access-lisp-data vsp) res)
    100                 (push-type&name (incf cellno))
    101                 (decf vsp))
    102               (if rest
    103                 (dotimes (i opt)        ; all optionals were specified
    104                   (declare (fixnum i))
    105                   (when (<= vsp child-vsp) (return))
    106                   (push (access-lisp-data vsp) res)
    107                   (push-type&name (incf cellno))
    108                   (decf vsp))
    109                 (let ((offset (+ opt (if restp 1 0) (if keys (+ keys keys) 0)))
    110                       (optionals nil))
    111                   (dotimes (i opt)      ; some optionals may have been omitted
    112                     (declare (fixnum i))
    113                     (when (<= vsp child-vsp) (return))
    114                     (let ((value (access-lisp-data vsp)))
    115                       (if optinit
    116                         (if (access-lisp-data (- vsp offset))
    117                           (progn
    118                             (push value optionals)
    119                             (push-type&name (incf cellno))
    120                             (return)))
    121                         (progn (push value optionals)
    122                                (push-type&name (incf cellno))))
    123                       (decf vsp)))
    124                   (unless optinit
    125                     ;; assume that null optionals were not passed.
    126                     (while (and optionals (null (car optionals)))
    127                       (pop optionals)
    128                       (pop types)
    129                       (pop names)))
    130                   (setq rest (nreconc optionals rest))))
    131               (values (nreconc res rest) (nreverse types) (nreverse names)
    132                       t nclosed))))))))
     41  (let* ((arglist (arglist-from-map lfun))
     42         (args (arguments-and-locals context frame lfun pc))
     43         (state :required))
     44    (collect ((arg-values)
     45              (types)
     46              (names))
     47      (dolist (arg arglist)
     48        (if (or (member arg lambda-list-keywords)
     49                (eq arg '&lexpr))
     50          (setq state arg)
     51          (let* ((pair (pop args)))
     52            (case state
     53              (&lexpr
     54               (with-list-from-lexpr (rest (cdr pair))
     55                 (dolist (r rest) (arg-values r) (names nil) (types nil)))
     56               (return))
     57              (&rest
     58               (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
     59               (return))
     60              (&key
     61               (arg-values arg)
     62               (names nil)
     63               (types nil)))
     64            (let* ((value (cdr pair)))
     65              (if (eq value (%unbound-marker))
     66                (return))
     67              (names (car pair))
     68              (arg-values value)
     69              (types nil)))))
     70      (values (arg-values) (types) (names)))))
    13371
    13472;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's
  • branches/ia32/lib/macros.lisp

    r7244 r7287  
    26782678      (push `(,var (slot-value ,instance ',slot-name)) bindings))
    26792679    `(let ((,instance ,instance-form))
    2680        ,@(unless bindings (list `(declare (ignore ,instance))))
     2680       ,@(if bindings
     2681             (list `(declare (ignorable ,instance)))
     2682             (list `(declare (ignore ,instance))))
    26812683       (symbol-macrolet ,(nreverse bindings)
    26822684         ,@body))))
     
    26972699      (push `(,var (,reader ,instance)) bindings))
    26982700    `(let ((,instance ,instance-form))
    2699        ,@(unless bindings (list `(declare (ignore ,instance))))
     2701       ,@(if bindings
     2702             (list `(declare (ignorable ,instance)))
     2703             (list `(declare (ignore ,instance))))
    27002704       (symbol-macrolet ,(nreverse bindings)
    27012705         ,@body))))
  • branches/ia32/lib/misc.lisp

    r5920 r7287  
    696696
    697697(%fhave 'df #'disassemble)
     698
     699(defun local-svn-revision ()
     700  (or
     701   ;; svn2cvs uses a .svnrev file to sync CVS and SVN; if present,
     702   ;; it contains the svn revision in decimal.
     703   (with-open-file (f "ccl:\\.svnrev" :direction :input :if-does-not-exist nil)
     704     (when f (read f)))
     705   (with-output-to-string (s)
     706    (multiple-value-bind (status exit-code)
     707        (external-process-status
     708         (run-program "svnversion"  (list  (native-translated-namestring "ccl:") "/trunk/ccl"):output s))
     709      (when (and (eq :exited status) (zerop exit-code))
     710        (with-input-from-string (output (get-output-stream-string s))
     711          (let* ((line (read-line output nil nil)))
     712            (when (and line (parse-integer line :junk-allowed t) )
     713              (return-from local-svn-revision line)))))))))
  • branches/ia32/lib/pathnames.lisp

    r5677 r7287  
    457457         (type (and pos (%substr pstr (%i+ pos 1) end)))
    458458         (name (unless (eq (or pos end) 0) (if pos (%substr pstr 0 pos) pstr))))
    459     (and (cond ((eq name-pat :unspecific) (null name))
    460                ((null name-pat) T)
     459    (and (cond ((or (eq name-pat :unspecific) (null name-pat)) (null name))
    461460               (t (%path-pstr*= name-pat (or name ""))))
    462          (cond ((eq type-pat :unspecific) (null type))
    463                ((null type-pat) T)
     461         (cond ((or (null type-pat) (eq type-pat :unspecific)) (null type))
    464462               (t (%path-pstr*= type-pat (or type "")))))))
    465463
  • branches/ia32/lisp-kernel/lisp-debug.c

    r7017 r7287  
    3838  debug_kill
    3939} debug_command_return;
     40
     41
    4042
    4143typedef debug_command_return (*debug_command) (ExceptionInformation *,
     
    702704   NULL,
    703705   'A'},
    704 #endif
    705706  {debug_identify_exception,
    706707   "Describe the current exception in greater detail",
     
    709710   NULL,
    710711   'D'},
     712#endif
    711713  {debug_show_registers,
    712714   "Show raw GPR/SPR register values",
     
    837839  va_list args;
    838840  debug_command_return state = debug_continue;
     841  int in_foreign_code = (why & debug_foreign_exception);
    839842
    840843  if (threads_initialized) {
     
    846849  fprintf(stderr, "\n");
    847850  va_end(args);
     851  if (in_foreign_code) {
     852    fprintf(stderr, "Exception occurred while executing foreign code\n");
     853    why = (why & ~debug_foreign_exception);
     854  }
     855
    848856  if (lisp_global(BATCH_FLAG)) {
    849857    abort();
     
    888896
    889897}
     898
     899void
     900FBug(ExceptionInformation *xp, const char *format, ...)
     901{
     902  va_list args;
     903  char s[512];
     904 
     905  va_start(args, format);
     906  vsnprintf(s, sizeof(s),format, args);
     907  va_end(args);
     908  lisp_Debugger(xp, NULL, debug_entry_bug | debug_foreign_exception , s);
     909
     910}
     911
    890912void
    891913lisp_bug(char *string)
  • branches/ia32/lisp-kernel/lisp-exceptions.h

    r6511 r7287  
    112112
    113113void Bug(ExceptionInformation *, const char *format_string, ...);
     114void FBug(ExceptionInformation *, const char *format_string, ...);
    114115int gc_from_xp(ExceptionInformation *, signed_natural);
    115116int purify_from_xp(ExceptionInformation *, signed_natural);
     
    145146void resume_other_threads(Boolean);
    146147
     148#define debug_foreign_exception 0x80
    147149
    148150#endif /* __lisp_exceptions_h__ */
  • branches/ia32/lisp-kernel/x86-exceptions.c

    r7244 r7287  
    963963  if (! handle_exception(signum, info, context, tcr, old_valence)) {
    964964    char msg[512];
     965    int foreign = (old_valence == TCR_STATE_LISP) ? 0 : debug_foreign_exception;
    965966
    966967    snprintf(msg, sizeof(msg), "Unhandled exception %d at 0x%lx, context->regs at #x%lx", signum, xpPC(context), (natural)xpGPRvector(context));
    967968   
    968     if (lisp_Debugger(context, info, signum, msg)) {
     969    if (lisp_Debugger(context, info, signum | foreign, msg)) {
    969970      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
    970971    }
     
    11341135
    11351136
     1137#ifndef USE_SIGALTSTACK
     1138void
     1139arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
     1140{
     1141  TCR *tcr = get_interrupt_tcr(false);
     1142  area *vs = tcr->vs_area;
     1143  BytePtr current_sp = (BytePtr) current_stack_pointer();
     1144
     1145  if ((current_sp >= vs->low) &&
     1146      (current_sp < vs->high)) {
     1147    handle_signal_on_foreign_stack(tcr,
     1148                                   signal_handler,
     1149                                   signum,
     1150                                   info,
     1151                                   context,
     1152                                   (LispObj)__builtin_return_address(0)
     1153#ifdef DARWIN_GS_HACK
     1154                                 , false
     1155#endif
     1156
     1157                                   );
     1158  } else {
     1159    signal_handler(signum, info, context, tcr, 0);
     1160  }
     1161}
     1162
     1163#else
    11361164void
    11371165altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
     
    11401168#if 1
    11411169  if (tcr->valence != TCR_STATE_LISP) {
    1142     Bug(context, "exception in foreign context");
     1170    FBug(context, "exception in foreign context");
    11431171  }
    11441172#endif
     
    11491177);
    11501178}
     1179#endif
    11511180
    11521181void
     
    13031332{
    13041333#ifndef DARWIN 
    1305   install_signal_handler(SIGILL, altstack_signal_handler);
    1306  
    1307   install_signal_handler(SIGBUS, altstack_signal_handler);
    1308   install_signal_handler(SIGSEGV,altstack_signal_handler);
    1309   install_signal_handler(SIGFPE, altstack_signal_handler);
     1334  void *handler = (void *)
     1335#ifdef USE_SIGALTSTACK
     1336    altstack_signal_handler
     1337#else
     1338    arbstack_signal_handler;
     1339#endif
     1340  ;
     1341  install_signal_handler(SIGILL, handler);
     1342 
     1343  install_signal_handler(SIGBUS, handler);
     1344  install_signal_handler(SIGSEGV,handler);
     1345  install_signal_handler(SIGFPE, handler);
    13101346#else
    13111347  install_signal_handler(SIGTRAP,bogus_signal_handler);
     
    15511587  stack_t stack;
    15521588  stack.ss_sp = a->low;
    1553   a->low += 8192;
    1554   stack.ss_size = 8192;
     1589  a->low += SIGSTKSZ*8;
     1590  stack.ss_size = SIGSTKSZ*8;
    15551591  stack.ss_flags = 0;
    15561592  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
     
    21012137    raise_pending_interrupt(tcr);
    21022138  } else {
    2103     Bug(NULL, "no xp here!\n");
     2139    FBug(NULL, "no xp here!\n");
    21042140  }
    21052141#ifdef DEBUG_MACH_EXCEPTIONS
  • branches/ia32/lisp-kernel/x86-exceptions.h

    r7243 r7287  
    152152#undef USE_SIGALTSTACK
    153153#else
    154 #define USE_SIGALTSTACK 1
     154/* #define USE_SIGALTSTACK 1 */
     155#undef USE_SIGALTSTACK
    155156#endif
    156157
  • branches/ia32/xdump/xfasload.lisp

    r6212 r7287  
    10641064          (xload-save-list (setq *xload-cold-load-functions*
    10651065                                 (nreverse *xload-cold-load-functions*))))
     1066    (let* ((svnrev (local-svn-revision)))
     1067      (setf (xload-symbol-value (xload-copy-symbol '*openmcl-svn-revision*))
     1068            (typecase svnrev
     1069              (fixnum (ash svnrev *xload-target-fixnumshift*))
     1070              (string (xload-save-string svnrev))
     1071              (t *xload-target-nil*))))
     1072                             
    10661073    (when *xload-show-cold-load-functions*
    10671074      (format t "~&cold-load-functions list:")
Note: See TracChangeset for help on using the changeset viewer.