changelog shortlog graph tags branches files raw help

Mercurial > core / changeset: bugfixes, x test

changeset 355: 09f056e9a789
parent 354: aeef48e62bc0
child 356: aac665e2f5bf
author: Richard Westhaver <ellis@rwest.io>
date: Tue, 14 May 2024 18:33:03 -0400
files: lisp/bin/homer.lisp lisp/std/pkg.lisp lisp/std/tests.lisp x.lisp
description: bugfixes, x test
     1.1--- a/lisp/bin/homer.lisp	Tue May 14 16:44:11 2024 -0400
     1.2+++ b/lisp/bin/homer.lisp	Tue May 14 18:33:03 2024 -0400
     1.3@@ -13,7 +13,7 @@
     1.4 (declaim (type home-config *home-config*))
     1.5 (defvar *home-config*)
     1.6 (defvar *home-hidden-paths* (nconc *hidden-paths* (list "stash" "store" "readme.org" ".hgignore")))
     1.7-
     1.8+(defvar *homer-force* nil)
     1.9 (defclass home-config (sxp id)
    1.10   ((user :initform *user* :initarg :user :type string)
    1.11    (path :initform nil :initarg :path :type (or pathname null))
    1.12@@ -72,11 +72,13 @@
    1.13 (defopt homer-help (print-help $cli))
    1.14 (defopt homer-version (print-version $cli))
    1.15 (defopt homer-log-level (when $val (setq *log-level* :debug)))
    1.16+(defopt homer-force (when $val (setq *homer-force* t)))
    1.17 
    1.18 (defcmd homer-show
    1.19   (describe *home-config*))
    1.20 
    1.21 (defun mtime (path) (sb-posix:stat-mtime (sb-posix:stat path)))
    1.22+(defun ctime (path) (sb-posix:stat-ctime (sb-posix:stat path)))
    1.23 
    1.24 (defun compare-home-file (src)
    1.25   "Compare a SRC path to what is stored in the user's home. Return a cons with
    1.26@@ -88,7 +90,8 @@
    1.27          (status (cond
    1.28                    ((null m2) :new)
    1.29                    ((> m1 m2) :pull)
    1.30-                   ((< m1 m2) :push)
    1.31+                   ((< m1 m2) (unless (= (ctime home) m2)
    1.32+                                :push))
    1.33                    (t))))
    1.34     (cons status (cons src home))))
    1.35 
    1.36@@ -140,7 +143,11 @@
    1.37       (:new (progn
    1.38               (println (format nil ":NEW ~A" (cddr form)))
    1.39               (homer-copy (cadr form) (cddr form))))
    1.40-      (:push (warn! "skipping file:" (cddr form)))
    1.41+      (:push (if *homer-force*
    1.42+                 (progn
    1.43+                   (println (format nil ":OVERWRITE ~A" (cddr form)))
    1.44+                   (homer-copy (cadr form) (cddr form)))
    1.45+                 (trace! "skipping file:" (cddr form))))
    1.46       (t nil))))
    1.47 
    1.48 (defcmd homer-push
    1.49@@ -171,11 +178,12 @@
    1.50   :name "homer"
    1.51   :version "0.1.0"
    1.52   :description "user home manager"
    1.53-  :thunk homer-show
    1.54+  :thunk homer-check
    1.55   :opts (make-opts
    1.56           (:name "level" :global t :description "set the log level" :thunk homer-log-level)
    1.57           (:name "help" :global t :description "print help" :thunk homer-help)
    1.58-          (:name "version" :global t :description "print version" :thunk homer-version))
    1.59+          (:name "version" :global t :description "print version" :thunk homer-version)
    1.60+          (:name "force" :global t :description "use force" :thunk homer-force))
    1.61   :cmds (make-cmds
    1.62          (:name show :thunk homer-show)
    1.63          (:name check :thunk homer-check)
     2.1--- a/lisp/std/pkg.lisp	Tue May 14 16:44:11 2024 -0400
     2.2+++ b/lisp/std/pkg.lisp	Tue May 14 18:33:03 2024 -0400
     2.3@@ -183,23 +183,6 @@
     2.4    :task-pool-oracle :task-pool-jobs :task-pool-stages
     2.5    :task-pool-workers :task-pool-results))
     2.6 
     2.7-(defpkg :std/readtable
     2.8-  (:use :cl)
     2.9-  (:import-from :std/named-readtables :defreadtable)
    2.10-  (:import-from :std/sym :symb)
    2.11-  (:import-from :std/list :defmacro!) ;; kludge
    2.12-  (:export
    2.13-   ;; readtable
    2.14-   :|#"-reader|
    2.15-   :|#`-reader|
    2.16-   :|#f-reader|
    2.17-   :|#$-reader|
    2.18-   :segment-reader
    2.19-   :match-mode-ppcre-lambda-form
    2.20-   :subst-mode-ppcre-lambda-form
    2.21-   :|#~-reader|
    2.22-   :_))
    2.23-
    2.24 (defpkg :std/macs
    2.25   (:use :cl)
    2.26   (:import-from :std/sym :symb :mkstr :make-gensym-list :once-only :with-gensyms)
    2.27@@ -278,6 +261,24 @@
    2.28    :curry
    2.29    :rcurry))
    2.30 
    2.31+(defpkg :std/readtable
    2.32+  (:use :cl)
    2.33+  (:import-from :std/named-readtables :defreadtable)
    2.34+  (:import-from :std/fu :curry :rcurry :compose)
    2.35+  (:import-from :std/sym :symb)
    2.36+  (:import-from :std/list :defmacro!) ;; kludge
    2.37+  (:export
    2.38+   ;; readtable
    2.39+   :|#"-reader|
    2.40+   :|#`-reader|
    2.41+   :|#f-reader|
    2.42+   :|#$-reader|
    2.43+   :segment-reader
    2.44+   :match-mode-ppcre-lambda-form
    2.45+   :subst-mode-ppcre-lambda-form
    2.46+   :|#~-reader|
    2.47+   :_))
    2.48+
    2.49 (defpkg :std/bit
    2.50   (:use :cl)
    2.51   (:import-from :std/type :octet :octet-vector)
     3.1--- a/lisp/std/tests.lisp	Tue May 14 16:44:11 2024 -0400
     3.2+++ b/lisp/std/tests.lisp	Tue May 14 18:33:03 2024 -0400
     3.3@@ -7,7 +7,7 @@
     3.4 ;;; Code:
     3.5 (in-package :std-user)
     3.6 (defpkg :std/tests
     3.7-  (:use :cl :std :rt :sb-thread))
     3.8+  (:use :cl :std :rt :sb-thread :std/fu))
     3.9 (in-package :std/tests)
    3.10 (defsuite :std)
    3.11 (in-suite :std)
    3.12@@ -15,7 +15,8 @@
    3.13 ;; prevent threadlocks
    3.14 ;; (setf sb-unix::*on-dangerous-wait* :error)
    3.15 
    3.16-(deftest readtables ()
    3.17+;; TODO 2024-05-14: fix compilation order of std/fu vs std/readtables
    3.18+(deftest readtables (:disabled nil)
    3.19   "Test :std readtable"
    3.20   (is (typep #`(,a1 ,a1 ',a1 ,@a1) 'function))
    3.21   (is (string= #"test "foo" "# "test \"foo\" "))
    3.22@@ -179,10 +180,10 @@
    3.23   (is (= 3 (acond ((1+ 1) (1+ it)))))
    3.24   (loop for x in '(1 2 3)
    3.25         for y in (funcall (alet ((a 1) (b 2) (c 3))
    3.26-                            (lambda () (mapc #'1+ (list a b c)))))
    3.27+                                (lambda () (mapc #'1+ (list a b c)))))
    3.28         collect (is (= x y))))
    3.29 
    3.30-(deftest pan ()
    3.31+(deftest pan (:disabled t)
    3.32   "Test standard pandoric macros"
    3.33   (let ((p
    3.34 	  (plambda (a) (b c)
    3.35@@ -241,14 +242,13 @@
    3.36                x) ;; 2
    3.37          '(42 42 2)))))
    3.38 
    3.39-(deftest bits (:disabled nil)
    3.40-  (eval-always
    3.41-    (define-bitfield testbits
    3.42-      (a boolean)
    3.43-      (b (signed-byte 2))
    3.44-      (c (unsigned-byte 3) :initform 1)
    3.45-      (d (integer -100 100))
    3.46-      (e (member foo bar baz))))
    3.47+(deftest bits (:disabled t)
    3.48+  (define-bitfield testbits
    3.49+    (a boolean)
    3.50+    (b (signed-byte 2))
    3.51+    (c (unsigned-byte 3) :initform 1)
    3.52+    (d (integer -100 100))
    3.53+    (e (member foo bar baz)))
    3.54   (let ((bits (make-testbits)))
    3.55     (is (not (testbits-a bits)))
    3.56     (is (= 0 (testbits-b bits)))
     4.1--- a/x.lisp	Tue May 14 16:44:11 2024 -0400
     4.2+++ b/x.lisp	Tue May 14 18:33:03 2024 -0400
     4.3@@ -21,7 +21,7 @@
     4.4   ;; (asdf:load-asd (probe-file #P"ext/cl-ppcre.asd"))
     4.5   )
     4.6 
     4.7-(asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/std.asd")))
     4.8+(asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/")))
     4.9 (asdf:load-system :std)
    4.10 
    4.11 (defpackage :x
    4.12@@ -111,6 +111,7 @@
    4.13 test
    4.14 compile
    4.15 build
    4.16+test
    4.17 run
    4.18 save
    4.19 install")))
    4.20@@ -178,12 +179,17 @@
    4.21       ;; self save
    4.22       (sb-ext:run-program "x.lisp" nil :input t :output t)))
    4.23 
    4.24+(asdf:load-asd (probe-file (merge-pathnames "log.asd" "lisp/lib/log/")))
    4.25+(asdf:load-asd (probe-file (merge-pathnames "rt.asd" "lisp/lib/rt/")))
    4.26+(asdf:load-system :log)
    4.27+(asdf:load-system :rt)
    4.28+(ql:quickload :rt)
    4.29+
    4.30 (defun x-test (args)
    4.31   (if args
    4.32       (let ((name (car args)))
    4.33-        (ql:quickload name)
    4.34-        (ql:quickload (format nil "~A/TESTS" name))
    4.35-        (ignore-some-conditions (warning) (asdf:test-system name)))
    4.36+        (ql:quickload (string-upcase (format nil "~A/tests" name)))
    4.37+        (rt:do-tests (string-upcase name) t))
    4.38       (bail "missing arg")))
    4.39 
    4.40 (defun x-run (args)