diff --git a/base/hash-tables.lisp b/base/hash-tables.lisp index 0063c6e46235051675f4558be30631db0b7e6e1d..89b3b566266a132a0a152ec92088471fa101f8bc 100644 --- a/base/hash-tables.lisp +++ b/base/hash-tables.lisp @@ -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))))) diff --git a/base/lists.lisp b/base/lists.lisp index 11553324c2701a56b455f929dd0f644c51a104a1..26580a3f0636b17bf1eb03ebca25af214ab530df 100644 --- a/base/lists.lisp +++ b/base/lists.lisp @@ -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 diff --git a/base/macros.lisp b/base/macros.lisp index 7e48e38629380d1ded66234350d7cbb9b2e23a7b..b95e348b6071bb3ee2de717b17b9e2d2360a3cdc 100644 --- a/base/macros.lisp +++ b/base/macros.lisp @@ -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 diff --git a/base/packages.lisp b/base/packages.lisp index e0164b886e9077a8e3cd274d05d8656f255747ac..22e31939629714ba1ab06ad263035854273ea767 100644 --- a/base/packages.lisp +++ b/base/packages.lisp @@ -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) diff --git a/base/parse-cl-syntax.lisp b/base/parse-cl-syntax.lisp index 1c57edd8b92e600328ce0717f39931f88ffbda5a..8cdd5dd35ad17048bee6f9a8a72b431997164c03 100644 --- a/base/parse-cl-syntax.lisp +++ b/base/parse-cl-syntax.lisp @@ -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) diff --git a/filesystem/files.lisp b/filesystem/files.lisp index 353f5dc44c0bb89f42cc7e1dd3732cddabb7c2c9..870dc2b4ce0405328123958cfecd9d1fae96095c 100644 --- a/filesystem/files.lisp +++ b/filesystem/files.lisp @@ -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 diff --git a/filesystem/pathnames.lisp b/filesystem/pathnames.lisp index d38a0cf071d884b52027bf4eb81ddc6c51d1c353..d698777a390e2788b9a273fcca629cdb485cd377 100644 --- a/filesystem/pathnames.lisp +++ b/filesystem/pathnames.lisp @@ -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 diff --git a/package.lisp b/package.lisp index ef7972c66153ac5b7c59cccf99c50042af84d7d4..9ad654e0e7d97faa1547941428db392da01cf7da 100644 --- a/package.lisp +++ b/package.lisp @@ -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