Changeset 8643


Ignore:
Timestamp:
02/26/05 17:46:40 (16 years ago)
Author:
piso
Message:

Work in progress.

Location:
trunk/j/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/inspect.lisp

    r8164 r8643  
    11;;; inspect.lisp
    22;;;
    3 ;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: inspect.lisp,v 1.10 2004-11-18 15:47:58 piso Exp $
     3;;; Copyright (C) 2003-2005 Peter Graves
     4;;; $Id: inspect.lisp,v 1.11 2005-02-26 17:45:58 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    126126    (push *inspected-object* *inspected-object-stack*))
    127127  (setf *inspected-object* obj)
    128   (let ((*inspect-break* t)
    129         (*debug-level* (1+ *debug-level*)))
     128  (let* ((*inspect-break* t)
     129         (*debug-level* (1+ *debug-level*)))
     130    (setf *** **
     131          ** *
     132          * obj)
    130133    (display-current)
    131134    (catch 'inspect-exit
    132135      (tpl::repl)))
     136  (setf *** **
     137        ** *
     138        * obj)
    133139  (values))
    134140
     
    143149                   (progn
    144150                     (setf *inspected-object* (pop *inspected-object-stack*))
     151                     (setf *** **
     152                           ** *
     153                           * *inspected-object*)
    145154                     (display-current))
    146155                   (format t "Object has no parent.")))
     
    162171                                  (setf *inspected-object*
    163172                                        (elt *inspected-object* index))
     173                                  (setf * *inspected-object*)
    164174                                  (display-current)))
    165175                            (format t "Object has no selectable components.")))
     
    170180                        (push *inspected-object* *inspected-object-stack*)
    171181                        (setf *inspected-object* (cdr (elt parts index)))
     182                        (setf * *inspected-object*)
    172183                        (display-current)))))))))
  • trunk/j/src/org/armedbear/lisp/subtypep.lisp

    r8493 r8643  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: subtypep.lisp,v 1.58 2005-02-06 18:30:57 piso Exp $
     4;;; $Id: subtypep.lisp,v 1.59 2005-02-26 17:44:10 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    226226              (make-ctype 'REAL type))
    227227             (COMPLEX
    228               (make-ctype 'COMPLEX type)))))))
     228              (make-ctype 'COMPLEX type))
     229             (FUNCTION
     230              (make-ctype 'FUNCTION type)))))))
    229231
    230232(defun csubtypep-array (ct1 ct2)
     
    318320                 (dim (cadr i2))
    319321                 (size (car i1)))
    320              (unless (memq element-type '(bit *))
     322             (unless (or (memq element-type '(bit *))
     323                         (equal element-type '(integer 0 1)))
    321324               (return-from csubtypep-array (values nil t)))
    322325             (when (integerp size)
     
    425428           (values nil nil))))))
    426429
     430(defun csubtypep-function (ct1 ct2)
     431  (let ((type1 (ctype-type ct1))
     432        (type2 (ctype-type ct2)))
     433    (cond ((and (listp type1) (atom type2))
     434           (values t t))
     435          (t
     436           (values nil nil)))))
     437
    427438(defun csubtypep (ctype1 ctype2)
    428439  (cond ((null (and ctype1 ctype2))
     
    432443        ((eq (ctype-super ctype1) 'array)
    433444         (csubtypep-array ctype1 ctype2))
     445        ((eq (ctype-super ctype1) 'function)
     446         (csubtypep-function ctype1 ctype2))
    434447        (t
    435448         (values nil nil))))
     
    525538          ((null (or i1 i2))
    526539           (return-from %subtypep (values (simple-subtypep t1 t2) t)))
    527           ((eq t2 'sequence)
     540          ((eq t2 'SEQUENCE)
    528541           (cond ((memq t1 '(null cons list))
    529542                  (values t t))
     
    533546                  (values t t))
    534547                 ((memq t1 '(array simple-array))
    535                   (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
    536                       (values t t)
    537                       (values nil t)))
     548                  (cond ((and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
     549                         (values t t))
     550                        ((and (cdr i1) (eql (cadr i1) 1))
     551                         (values t t))
     552                        (t
     553                         (values nil t))))
    538554                 (t (values nil (known-type-p t1)))))
    539555          ((eq t1 'float)
  • trunk/j/src/org/armedbear/lisp/trace.lisp

    r8612 r8643  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: trace.lisp,v 1.12 2005-02-20 14:41:05 piso Exp $
     4;;; $Id: trace.lisp,v 1.13 2005-02-26 17:46:40 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    5959              (lambda (&rest args)
    6060                (with-standard-io-syntax
     61                  (let ((*print-readably* nil)
     62                        (*print-structure* nil))
    6163                    (format *trace-output* (indent "~D: ~S~%") *trace-depth*
    62                             (cons name args)))
     64                            (cons name args))))
    6365                (when breakp
    6466                  (break))
     
    6769                  (decf *trace-depth*)
    6870                  (with-standard-io-syntax
    69                     (format *trace-output* (indent "~D: ~A returned") *trace-depth* name)
    70                     (dolist (val r)
    71                       (format *trace-output* " ~S" val))
    72                     (terpri *trace-output*))
     71                    (let ((*print-readably* nil)
     72                          (*print-structure* nil))
     73                      (format *trace-output* (indent "~D: ~A returned") *trace-depth* name)
     74                      (dolist (val r)
     75                        (format *trace-output* " ~S" val))
     76                      (terpri *trace-output*)))
    7377                  (values-list r)))))
    7478        (let ((*warn-on-redefinition* nil))
Note: See TracChangeset for help on using the changeset viewer.