Changeset 7255


Ignore:
Timestamp:
Sep 19, 2007, 7:52:57 AM (12 years ago)
Author:
gb
Message:

FRAME-REQUIRED-ARGS: try to make better. This is only used by SLIME;
it was once used for frame restarting. Try to make the result reasonable
in the SLIME case.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/lib/backtrace-lds.lisp

    r4535 r7255  
    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
Note: See TracChangeset for help on using the changeset viewer.