Commit 6a1bfd64 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Delete some functions and macros that are redundant with alexandria or asdf.

parent 171f522d
......@@ -25,7 +25,7 @@
h))
(defmacro hashmacro (name &rest rest)
(with-gensyms (hashname)
(let ((hashname (gensym "HASHNAME")))
`(let ((,hashname (make-hash-table ,@rest)))
(defmacro ,name (obj) `(gethash ,obj ,,hashname)))))
......
......@@ -31,11 +31,13 @@
"N first elements of list L -- complement of (NTHCDR N L)"
(subseq l 0 n))
#| ;; use ALEXANDRIA:MAPPEND instead
(defun append/list (list)
(reduce #'append list :from-end t))
(defun mappend (&rest rest)
"like mapcan, but works on lists resulting from quasi-quoted expressions"
(append/list (apply #'mapcar rest)))
|#
(defun mapcar2 (fun list)
"simple mapcar for functions returning 2 values,
......@@ -95,10 +97,12 @@ returning the two lists of the values returned by the function."
(defmacro dolist-with-rest (formals list &body body)
`(dolist-with-rest-fun ,list #'(lambda ,formals ,@body)))
#| use ALEXANDRIA:EXTREMUM instead
(defun extremum (sequence predicate &key (key #'identity))
(reduce #'(lambda (x y)
(if (funcall predicate (funcall key x) (funcall key y)) x y))
sequence))
|#
(defun length=-p (x y)
;(= (length x) (length y))
......@@ -177,7 +181,7 @@ where KEYWORD defaults to :ARG and SUPPLIED-P defaults to ARG."
(if-supplied (if (and (listp ks) (<= 3 (length ks)))
(third ks)
key)))
(with-gensyms (foo)
(let ((foo (gensym)))
`(let ((,foo (make-keys ,@(rest keys))))
(if ,suppliedp (cons ,kw (cons ,if-supplied ,foo)) ,foo))))))
......@@ -202,7 +206,12 @@ where KEYWORD defaults to :ARG and SUPPLIED-P defaults to ARG."
May alter the cons cells that constitute the spine of the alist"
(multiple-value-bind (al-dummies al-vals al-newvals al-setter al-getter)
(get-setf-expansion alist env)
(with-gensyms (x-val al-val assoc cons head store)
(let ((x-val (gensym))
(al-val (gensym))
(assoc (gensym))
(cons (gensym))
(head (gensym))
(store (gensym)))
(values `(,x-val ,@al-dummies ,al-val ,assoc ,cons ,head)
`(,x ,@al-vals
,al-getter
......
......@@ -9,12 +9,14 @@
;;; Help in defining macros
#| use ALEXANDRIA:WITH-GENSYMS
(def*macro with-gensyms (syms &body body)
"Replaces given symbols with gensyms. Useful for creating macros.
This version by Paul Graham in On Lisp.
Mostly the same as cliki's WITH-UNIQUE-NAMES."
;; Note: we probably should be using it from alexandria or something
`(let ,(mapcar #'(lambda (s) `(,s (gensym ,(symbol-name s)))) syms) ,@body))
|#
(def*macro evaluating-once (vars &body body)
"Macro to use while defining a macro that needs to enforce that the
......@@ -62,7 +64,7 @@ CMUCL's EXT:ONCE-ONLY has a different interface."
(exporting-definitions
(define-modify-macro funcallf (f &rest args) xfuncall)
;;(define-modify-macro appendf (&rest args) append "Append onto list") ;; imported from ASDF
(define-modify-macro nconcf (&rest args) nconc "Destructively append onto list")
;;(define-modify-macro nconcf (&rest args) nconc "Destructively append onto list") ;; now from alexandria
(defun append1 (l x) (append l (list x)))
(define-modify-macro append1f (x) append1 "Append one element onto list"))
......@@ -272,12 +274,14 @@ outputs a tag plus a list of variable and their values, returns the last value"
"make a new array of same shape as given array"
(make-array (array-dimensions array)
:element-type (array-element-type array)))
#| use ALEXANDRIA:COPY-ARRAY instead
(defun copy-array (array)
"make a fresh (shallow) copy of an array"
(let ((new-array (copy-array-shape array)))
(loop :for i :below (array-total-size array) :do
(setf (row-major-aref new-array i) (row-major-aref array i)))
new-array))
|#
(defun fill-array (array value)
"fill an array with a value"
(fill
......@@ -309,10 +313,12 @@ outputs a tag plus a list of variable and their values, returns the last value"
; -----------------------------------------------------------------------------
;;; Higher-Order Functions
(defun compose/2 (f g)
#| use ALEXANDRIA:MULTIPLE-VALUE-COMPOSE and ALEXANDRIA:COMPOSE
(defun multiple-value-compose/2 (f g)
#'(lambda (&rest rest) (multiple-value-call f (apply g rest))))
(defun compose (&rest rest)
(reduce #'compose/2 rest :from-end t :initial-value #'identity))
(defun multiple-value-compose (&rest rest)
(reduce #'multiple-value-compose/2 rest :from-end t :initial-value #'identity))
|#
;;; Basic combinators
;; they call for some combinator-defining macros, that would handle
......@@ -329,11 +335,12 @@ outputs a tag plus a list of variable and their values, returns the last value"
(defmacro aif (test then &optional else)
`(let ((it ,test)) (if it ,then ,else)))
(with-gensyms (result test)
(defmacro if2 (test2 then &optional else)
(let ((result (gensym)) (test (gensym)))
`(mvbind (,result ,test) ,test2
(if (or ,test ,result) ,then ,else)))
(if (or ,test ,result) ,then ,else))))
(defmacro aif2 (test2 then &optional else)
(let ((test (gensym)))
`(mvbind (it ,test) ,test2
(if (or ,test it) ,then ,else))))
......@@ -427,6 +434,7 @@ is invoked as an ERROR-BEHAVIOUR."
(or (and (consp (cdr x)) (null (cddr x)))
(error-behaviour on-error tag x))))
#| ;; if you need it, use it from alexandria
(defun proper-list-p (x)
"Returns T if X is a proper list, NIL if it isn't. Checks for circularity"
(labels
......@@ -443,6 +451,7 @@ is invoked as an ERROR-BEHAVIOUR."
(recurse (cddr x) (cdr y))))
(check x nil)
(recurse (cdr x) x)))
|#
(defun single-arg (x) (cadr x))
(defmacro make-single-arg-form (name &optional
......@@ -459,7 +468,7 @@ is invoked as an ERROR-BEHAVIOUR."
to be evaluated as function call, macro call, or special form?"
(and (consp x)
(if on-error
(or (proper-list-p x) (error-behaviour on-error x))
(or (listp #|not bothering with proper-list-p|# x) (error-behaviour on-error x))
t)))
(defun literalp (x)
"predicate that tells whether X is the source form for a literal expression."
......@@ -547,7 +556,7 @@ shall be declared with a serial dependency in system definitions.
(defmacro fluid-let1 ((place val) &body body)
(multiple-value-bind (vars vals store-vars writer-form reader-form)
(get-setf-expansion place)
(with-gensyms (oldvals)
(let ((oldvals (gensym)))
`(let (,@(mapcar 'list vars vals) ,@store-vars)
(let ((,oldvals (multiple-value-list ,reader-form)))
(unwind-protect
......
......@@ -40,7 +40,7 @@
(sort (loop :for package :being :the :hash-keys :of h :using (:hash-value symbols)
:collect (list* x (s (package-name package)) (sl symbols)))
#'string<
:key (compose #'symbol-name #'second)))
:key #'(lambda (x) (symbol-name (second x)))))
(fs (name pl)
(loop :for p :in pl :thereis (find-symbol name p)))
(sx (sym)
......
......@@ -5,6 +5,7 @@
(defun list-starts-with-p (start list)
(and (consp list) (eq start (car list))))
#| use ALEXANDRIA:PARSE-BODY instead
(defun parse-body (body &key documentation whole)
"Parses BODY into (values remaining-forms declarations doc-string).
Documentation strings are recognized only if DOCUMENTATION is true.
......@@ -25,7 +26,7 @@ arguments when given."
(setf doc current))
(t
(return (values body decls doc))))))
|#
;;; decoding a macro-lambda-list or destructuring-lambda-list
(eval-when (:compile-toplevel :load-toplevel :execute)
......
......@@ -23,7 +23,7 @@
(element-type ''(unsigned-byte 8))
(external-format :default))
&body body)
(with-gensyms (stream length)
(let ((stream (gensym)) (length (gensym)))
(evaluating-once (buffer-size element-type external-format)
`(with-open-file (,stream ,file
:direction :input
......
......@@ -17,6 +17,7 @@
(defun pathname-base-pathname (pathname)
(make-pathname :directory nil :defaults pathname))
#| use ASDF:PATHNAME-PARENT-DIRECTORY-PATHNAME
(defun pathname-parent (pathname)
"Takes a pathname and returns the pathname of the parent directory
of the directory of the given pathname"
......@@ -30,6 +31,7 @@ of the directory of the given pathname"
(t
(merge-pathnames* +back-path+
(pathname-directory-pathname pathname)))))
|#
(defun top-level-name (name)
"This function takes a name, and returns everything up to the first \"/\" in the name"
......@@ -193,6 +195,7 @@ erroring out if some source of non-portability is found"
(ignore-errors (portable-pathname-from-string x))
t))
#|;; use ASDF:ENSURE-PATHNAME-ABSOLUTE instead.
(defun ensure-absolute-pathname (x)
(let ((path (pathname x)))
(cond
......@@ -202,12 +205,13 @@ erroring out if some source of non-portability is found"
(merge-pathnames* path))
(t
(truename (merge-pathnames* path *default-pathname-defaults*))))))
|#
(defun portable-namestring-prefix<= (x y)
(and (string-prefix-p x y)
(or (= (length x) (length y))
(eql #\/ (char y (length x))))))
#| use ASDF:ENSURE-DIRECTORY-PATHNAME instead
(defun ensure-pathname-is-directory (x)
(etypecase x
(string
......@@ -224,6 +228,7 @@ erroring out if some source of non-portability is found"
(not (member (pathname-version x) '(nil :unspecific :newest))))
(error "pathname ~S isn't a directory" x)
x))))
|#
(defun unwilden (pathspec)
(block :u
......
......@@ -10,23 +10,23 @@
|#
(defpackage #:fare-utils
(:use #:common-lisp #:asdf)
(:use #:common-lisp) ;; #:asdf
#+genera (:import-from #:scl #:boolean)
#+clisp (:shadow :with-gensyms)
;; #+clisp (:shadow :with-gensyms)
(:export
#:$buffer-size #:*package-misdefinition-warning-hook*
#:*safe-package* #:*standard-readtable*
#:+all-chars-base-feature+ #:absolute-pathname-p
#:accessors-equal-p #:acond #:acond2 #:adjust-size #:aif
#:aif2 #:alist->hash-table #:append/list #:association
#:aif2 #:alist->hash-table #:association
#:base-char-p #:binary-heap #:binomial-heap #:boolean
#:cached-size-mixin
#:call-with-input-stream #:call-with-output-stream
#:check-not-empty
#:clobber-file-if-different #:clobber-file-with-vector
#:combinationp #:compose #:compose/2 #:conc-gensym
#:combinationp #:conc-gensym ;; #:multiple-value-compose #:multiple-value-compose/2
#:conc-keyword #:conc-string #:conc-symbol #:conc-symbol-in
#:cond2 #:cons-tree-map #:copy-array #:copy-array-shape
#:cond2 #:cons-tree-map ;; #:copy-array #:copy-array-shape
#:copy-list-without-nth
#:copy-symbol-function #:copy-symbol-value #:dbg #:dbg-time
#:declaim-type #:declare-type #:def*class #:def*constant
......@@ -45,7 +45,7 @@
#:enable-fun #:equal-array #:error-behaviour #:eval-now
#:eval-once #:evaluating-once #:exchange-nodes #:export*
#:export-symbols #:export-symbols* #:exporting-definitions
#:extremum #:featurify
#:featurify ;; #:extremum
#:file-contents-equal-vector-p #:fill-array #:find-item
#:find-least-item #:find-node #:first-and-only #:firstn
#:get-file-contents
......@@ -58,7 +58,7 @@
#:list->vector #:list-of-integers
#:literalp #:make-collector #:make-defpackage-form
#:make-node #:make-predicate-symbol
#:make-single-arg-form #:mapcar2 #:mapmacro #:mappend
#:make-single-arg-form #:mapcar2 #:mapmacro ;; #:mappend #:append/list
#:maybe-adjust-size-down #:maybe-adjust-size-up
#:msg #:multiple-value-quote #:mvbind
#:mvcall #:mvlist #:mvprog1 #:mvquote #:mvsetq
......@@ -76,12 +76,12 @@
#:test-only #:the* #:ttest #:ttest* #:unfeaturify
#:vector->list #:vector-container-mixin
#:vector-container-ref #:with-buffered-file-contents
#:with-gensyms #:with-input #:with-magic-special-variables
#:with-input #:with-magic-special-variables ;; #:with-gensyms
#:with-magic-special-variables-safely #:with-msv #:with-msv*
#:with-output-stream #:with-input-stream
#:with-user-output-file #:xtime #:_
#:first-char #:last-char #:but-last-char
#:proper-list-p
;; #:proper-list-p
#:form-starting-with-p
#:make-hashset
#:split-list
......@@ -89,7 +89,8 @@
#:string-strip-prefix #:string-strip-suffix
#:+root-path+ #:+back-path+ #:merge-pathnames*
#:pathname-directory-pathname #:pathname-base-pathname
#:pathname-parent #:top-level-name #:directory-name-p
;; #:pathname-parent
#:top-level-name #:directory-name-p
#:portable-pathname-string-component-char-p
#:portable-pathname-string-component-p
#:portable-pathname-type-component-p
......@@ -105,17 +106,17 @@
#:portable-pathname-absolute-p
#:absolute-portable-namestring-p
#:portable-namestring-p
#:ensure-absolute-pathname
;;#:ensure-absolute-pathname ;; use ASDF:ENSURE-PATHNAME-ABSOLUTE
#:portable-namestring-prefix<=
#:ensure-pathname-is-directory
;;#:ensure-pathname-is-directory
#:rename-file-overwriting-target
#:unwilden
#:append1 #:append1f #:appendf #:nconcf #:funcallf
#:append1 #:append1f #:funcallf ;; #:appendf #:nconcf
#:with-nesting #:nest #:tsen
#:while-collecting
#:parse-macro-lambda-list
#:list-starts-with-p
#:parse-body
;; #:parse-body
#:parse-defsetf-lambda-list
#:identifierp
#:package-functions
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment