Changeset 13677 for release/1.5/source/library
- Timestamp:
- Apr 27, 2010, 1:09:52 PM (10 years ago)
- Location:
- release/1.5/source
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
release/1.5/source
- Property svn:mergeinfo changed
/trunk/source merged: 13676
- Property svn:mergeinfo changed
-
release/1.5/source/library/core-files.lisp
r13501 r13677 31 31 32 32 (export '(open-core close-core 33 core-heap-utilization map-core-areas map-core-region map-core-pointers33 core-heap-utilization map-core-areas 34 34 core-q core-l core-w core-b 35 35 core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p 36 36 core-uvtype core-uvtypep core-uvref core-uvsize 37 37 core-car core-cdr core-object-typecode-type 38 core-istruct-type core-struct-type core-instance-type core-function-type39 38 core-object-type-key core-type-string 40 39 copy-from-core core-list … … 48 47 core-instance-class 49 48 core-instance-p 50 core-string -equal49 core-string= 51 50 core-all-processes core-process-name 52 51 core-find-process-for-id … … 953 952 (defun core-symbol-pointers () 954 953 (or (core-info-symbol-ptrs (current-core)) 955 (let ((vector (make-array 1000 :adjustable t :fill-pointer 0)) 956 (keys (core-keyword-package))) 954 (let ((vector (make-array 1000 :adjustable t :fill-pointer 0))) 957 955 (map-core-areas (lambda (obj) 958 956 (when (core-symbolp obj) 959 (unless (eq (core-symbol-package obj) keys) 960 (vector-push-extend obj vector))))) 957 (vector-push-extend obj vector)))) 961 958 (setf (core-info-symbol-ptrs (current-core)) vector)))) 962 959 … … 965 962 966 963 967 (defun core-string -equal(ptr string &aux (len (length string)))964 (defun core-string= (ptr string &aux (len (length string))) 968 965 (assert (core-uvtypep ptr :simple-string)) 969 966 (when (eq (core-uvsize ptr) len) … … 972 969 973 970 (defun core-find-package (name &key error) 971 (when (integerp name) 972 (when (core-symbolp name) 973 (setq name (core-q name target::symbol.pname))) 974 (when (core-uvtypep name :simple-string) 975 (setq name (copy-from-core name :depth 1)))) 974 976 (setq name (string name)) 975 977 (or (loop for list-ptr = (core-all-packages-ptr) then (core-cdr list-ptr) … … 979 981 while (core-consp names-ptr) 980 982 as name-ptr = (core-car names-ptr) 981 thereis (core-string -equalname-ptr name))983 thereis (core-string= name-ptr name)) 982 984 do (return pkg-ptr)) 983 985 (and error (error "No package named ~s" name)))) … … 991 993 (copy-from-core (core-car (core-uvref pkg-ptr pkg.names)) :depth 1)) 992 994 993 (defun core-find-symbol (name &optional (package (symbol-package name)))994 ;; Unlike the realcl:find-symbol, this doesn't look for inherited symbols,995 (defun core-find-symbol (name &optional package) 996 ;; Unlike cl:find-symbol, this doesn't look for inherited symbols, 995 997 ;; you have to get the package right. 998 (when (integerp name) 999 (when (core-symbolp name) 1000 (when (null package) 1001 (setq package (core-symbol-package name))) 1002 (setq name (core-q name target::symbol.pname))) 1003 (when (core-uvtypep name :simple-string) 1004 (setq name (copy-from-core name :depth 1)))) 1005 (when (and (null package) (non-nil-symbolp name)) 1006 (setq package (symbol-package name))) 1007 (when (null package) (error "Package is required")) 996 1008 (let* ((symbol-name (string name)) 997 1009 (name-len (length symbol-name)) 998 (pkg-ptr (if ( integerp package)1010 (pkg-ptr (if (and (integerp package) (core-uvtypep package :package)) 999 1011 package 1000 1012 (core-find-package (if (packagep package) 1001 1013 (package-name package) 1002 (string package))1014 package) 1003 1015 :error t)))) 1004 (assert (core-uvtypep pkg-ptr :package))1005 1016 (multiple-value-bind (primary secondary) (hash-pname symbol-name name-len) 1006 1017 (flet ((findsym (htab-ptr) … … 1012 1023 until (eql sym 0) 1013 1024 do (when (and (core-symbolp sym) 1014 (core-string -equal(core-q sym target::symbol.pname) symbol-name))1025 (core-string= (core-q sym target::symbol.pname) symbol-name)) 1015 1026 (return (if (eq sym (nil-relative-symbol-address 'nil)) 1016 1027 (target-nil-value)
Note: See TracChangeset
for help on using the changeset viewer.