Add ELT, SEARCH, MISMATCH and APROPOS, DOCUMENTATION.
;;; target, and that src/bar/baz.lisp and src/bar/quux.lisp need to be
;;; compiled in the host
(defvar *source*
- '(("boot" :target)
- ("compat" :host)
- ("utils" :both)
- ("numbers" :target)
- ("char" :target)
- ("list" :target)
- ("array" :target)
- ("string" :target)
- ("sequence" :target)
- ("stream" :target)
- ("print" :target)
- ("package" :target)
- ("misc" :target)
- ("ffi" :both)
- ("read" :both)
- ("defstruct" :both)
- ("lambda-list" :both)
- ("backquote" :both)
+ '(("boot" :target)
+ ("compat" :host)
+ ("utils" :both)
+ ("numbers" :target)
+ ("char" :target)
+ ("list" :target)
+ ("array" :target)
+ ("string" :target)
+ ("sequence" :target)
+ ("stream" :target)
+ ("print" :target)
+ ("package" :target)
+ ("misc" :target)
+ ("documentation" :target)
+ ("ffi" :both)
+ ("read" :both)
+ ("defstruct" :both)
+ ("lambda-list" :both)
+ ("backquote" :both)
("compiler"
- ("codegen" :both)
- ("compiler" :both))
- ("toplevel" :target)))
+ ("codegen" :both)
+ ("compiler" :both))
+ ("toplevel" :target)))
(defun get-files (file-list type dir)
"Traverse FILE-LIST and retrieve a list of the files within which match
`((,(ecase (car c)
(integer 'integerp)
(cons 'consp)
+ (list 'listp)
+ (sequence 'sequencep)
(symbol 'symbolp)
(function 'functionp)
(float 'floatp)
`(let ((,g!x ,x))
(typecase ,g!x
,@clausules
- (t (error "~X fell through etypecase expression." ,g!x))))))
+ (t (error "~S fell through etypecase expression." ,g!x))))))
(defun notany (fn seq)
(not (some fn seq)))
--- /dev/null
+;;; documentation.lisp --- Accessing DOCUMENTATION
+
+;;; APROPOS and friends
+
+(defun map-apropos-symbols (function string package external-only)
+ (flet ((handle-symbol (symbol)
+ ;; TODO: it's implementation-dependent, though CHAR-EQUAL seems
+ ;; more reasonable nevertheless
+ (when (search string (symbol-name symbol) :test #'char=)
+ (funcall function symbol))))
+ (if package
+ (if external-only
+ (do-external-symbols (symbol package) (handle-symbol symbol))
+ (do-symbols (symbol package) (handle-symbol symbol)))
+ (if external-only
+ (do-all-external-symbols (symbol) (handle-symbol symbol))
+ (do-all-symbols (symbol) (handle-symbol symbol))))))
+
+(defun apropos-list (string &optional package external-only)
+ (let (symbols)
+ (map-apropos-symbols
+ (lambda (symbol)
+ (pushnew symbol symbols :test #'eq))
+ string package external-only)
+ symbols))
+
+(defun apropos (string &optional package external-only)
+ (map-apropos-symbols
+ (lambda (symbol)
+ (format t "~S" symbol)
+ (when (boundp symbol)
+ (format t " (bound)"))
+ (when (fboundp symbol)
+ (format t " (fbound)"))
+ (terpri))
+ string package external-only))
+
+;;; DESCRIBE
+
+;; TODO: this needs DESCRIBE-OBJECT as generic method
+;; TODO: indentation for nested paragraphs
+(defun describe (object &optional stream)
+ (declare (ignore stream))
+ (typecase object
+ (cons
+ (format t "~S~% [cons]~%" object))
+ (integer
+ (format t "~S~% [integer]~%" object))
+ (symbol
+ (format t "~S~% [symbol]~%" object)
+ (when (boundp object)
+ (format t "~%~A names a special variable:~% Value: ~A~%"
+ object (symbol-value object))
+ (let ((documentation (documentation object 'variable)))
+ (when documentation
+ (format t " Documentation:~%~A~%" documentation))))
+ (when (fboundp object)
+ (format t "~%~A names a function:~%" object)
+ (let ((documentation (documentation object 'function)))
+ (when documentation
+ (format t " Documentation:~%~A~%" documentation)))))
+ (string
+ (format t "~S~% [string]~%~%Length: ~D~%"
+ object (length object)))
+ (float
+ (format t "~S~% [float]~%" object))
+ (array
+ (format t "~S~% [array]~%" object))
+ (function
+ (format t "~S~% [function]~%" object)
+ (let ((documentation (documentation object 'function)))
+ (when documentation
+ (format t " Documentation:~%~A~%" documentation))))
+ (T
+ (warn "~A not implemented yet for ~A" 'describe object)))
+ (values))
(dolist (package *package-list*)
(map-for-in function (%package-symbols package))))
+(defun %map-all-external-symbols (function)
+ (dolist (package *package-list*)
+ (map-for-in function (%package-external-symbols package))))
+
(defmacro do-symbols ((var &optional (package '*package*) result-form)
&body body)
`(block nil
(defmacro do-all-symbols ((var &optional result-form) &body body)
`(block nil (%map-all-symbols (lambda (,var) ,@body)) ,result-form))
-(defun find-all-symbols (string)
+(defmacro do-all-external-symbols ((var &optional result-form) &body body)
+ `(block nil (%map-all-external-symbols (lambda (,var) ,@body)) ,result-form))
+
+(defun find-all-symbols (string &optional external-only)
(let (symbols)
(dolist (package *package-list* symbols)
(multiple-value-bind (symbol status) (find-symbol string package)
- (when status
+ (when (if external-only (eq status :external) status)
(pushnew symbol symbols :test #'eq))))))
(terpri)
x)
-(defun warn (string)
+(defun warn (fmt &rest args)
(write-string "WARNING: ")
- (write-line string))
+ (apply #'format t fmt args)
+ (terpri))
(defun print (x)
(write-line (prin1-to-string x))
(defun format-special (chr arg)
(case (char-upcase chr)
(#\S (prin1-to-string arg))
- (#\A (princ-to-string arg))))
+ (#\A (princ-to-string arg))
+ (#\D (princ-to-string arg))
+ (t
+ (warn "~S is not implemented yet, using ~~S instead" chr)
+ (prin1-to-string arg))))
(/debug "loading sequence.lisp!")
+(defun sequencep (thing)
+ (or (listp thing) (vectorp thing)))
+
(defun not-seq-error (thing)
(error "`~S' is not of type SEQUENCE" thing))
(if from-end
(reduce-list function sequence key start end initial-value ivp t)
(reduce-list function sequence key start end initial-value ivp nil))))))
+
+(defun elt (sequence index)
+ (when (< index 0)
+ (error "The index ~D is below zero." index))
+ (etypecase sequence
+ (list
+ (let ((i 0))
+ (dolist (elt sequence)
+ (when (eql index i)
+ (return-from elt elt))
+ (incf i))
+ (error "The index ~D is too large for ~A of length ~D." index 'list i)))
+ (array
+ (let ((length (length sequence)))
+ (when (>= index length)
+ (error "The index ~D is too large for ~A of length ~D." index 'vector length))
+ (aref sequence index)))))
+
+(defun mismatch (sequence1 sequence2 &key key (test #'eql testp) (test-not nil test-not-p)
+ (start1 0) (end1 (length sequence1))
+ (start2 0) (end2 (length sequence2)))
+ (let ((index1 start1)
+ (index2 start2))
+ (while (and (<= index1 end1) (<= index2 end2))
+ (when (or (eql index1 end1) (eql index2 end2))
+ (return-from mismatch (if (eql end1 end2) NIL index1)))
+ (unless (satisfies-test-p (elt sequence1 index1) (elt sequence2 index2)
+ :key key :test test :testp testp
+ :test-not test-not :test-not-p test-not-p)
+ (return-from mismatch index1))
+ (incf index1)
+ (incf index2))))
+
+(defun list-search (sequence1 list2 args)
+ (let ((length1 (length sequence1))
+ (position 0))
+ (while list2
+ (let ((mismatch (apply #'mismatch sequence1 list2 args)))
+ (when (or (not mismatch) (>= mismatch length1))
+ (return-from list-search position)))
+ (pop list2)
+ (incf position))))
+
+(defun vector-search (sequence1 vector2 args)
+ (let ((length1 (length sequence1)))
+ (dotimes (position (length vector2))
+ (let ((mismatch (apply #'mismatch sequence1 (subseq vector2 position) args)))
+ (when (or (not mismatch) (>= mismatch length1))
+ (return-from vector-search position))))))
+
+(defun search (sequence1 sequence2 &rest args &key key test test-not)
+ (unless (sequencep sequence1)
+ (not-seq-error sequence1))
+ (when (or (and (listp sequence1) (null sequence1))
+ (and (vectorp sequence1) (zerop (length sequence1))))
+ (return-from search 0))
+ (funcall
+ (typecase sequence2
+ (list #'list-search)
+ (array #'vector-search)
+ (t (not-seq-error sequence2)))
+ sequence1 sequence2 args))
(test (equal (reduce #'+ '(100) :key #'1+)
101))
+
+; MISMATCH
+(test (= (mismatch '(1 2 3) '(1 2 3 4 5 6)) 3))
+(test (= (mismatch '(1 2 3) #(1 2 3 4 5 6)) 3))
+(test (= (mismatch #(1 2 3) '(1 2 3 4 5 6)) 3))
+(test (= (mismatch #(1 2 3) #(1 2 3 4 5 6)) 3))
+
+; SEARCH
+(test (= (search '(1 2 3) '(4 5 6 1 2 3)) 3))
+(test (= (search '(1 2 3) #(4 5 6 1 2 3)) 3))
+(test (= (search #(1 2 3) '(4 5 6 1 2 3)) 3))
+(test (= (search #(1 2 3) #(4 5 6 1 2 3)) 3))
+(test (not (search '(foo) '(1 2 3))))
+(test (= (search '(1) '(4 5 6 1 2 3)) 3))
+(test (= (search #(1) #(4 5 6 1 2 3)) 3))
projects / jscl.git / commitdiff