1.1--- a/emacs/default.el Sat Aug 10 01:40:23 2024 -0400
1.2+++ b/emacs/default.el Sun Aug 11 01:53:06 2024 -0400
1.3@@ -255,6 +255,29 @@
1.4 (:indentation
1.5 (defpkg (as defpackage))
1.6 (define-package (as defpackage))))
1.7+
1.8+ ;; lisp font-lock defaults: https://www.n16f.net/blog/custom-font-lock-configuration-in-emacs/
1.9+ ;; (defface cl-character-face
1.10+ ;; '((default :inherit font-lock-constant-face))
1.11+ ;; "The face used to highlight Common Lisp character literals.")
1.12+
1.13+ ;; (defface cl-standard-function-face
1.14+ ;; '((default :inherit font-lock-keyword-face))
1.15+ ;; "The face used to highlight standard Common Lisp function symbols.")
1.16+
1.17+ ;; (defface cl-standard-value-face
1.18+ ;; '((default :inherit font-lock-variable-name-face))
1.19+ ;; "The face used to highlight standard Common Lisp value symbols.")
1.20+
1.21+ ;; (defvar cl-font-lock-keywords
1.22+ ;; (let* ((character-re (concat "#\\\\" lisp-mode-symbol-regexp "\\_>"))
1.23+ ;; (function-re (concat "(" (regexp-opt cl-function-names t) "\\_>"))
1.24+ ;; (value-re (regexp-opt cl-value-names 'symbols)))
1.25+ ;; `((,character-re . 'cl-character-face)
1.26+ ;; (,function-re
1.27+ ;; (1 'cl-standard-function-face))
1.28+ ;; (,value-re . 'cl-standard-value-face))))
1.29+
1.30 (setq common-lisp-style-default "core")
1.31 ;; (define-key slime-prefix-map (kbd "i") 'clouseau-inspect)
1.32 (setq slime-threads-update-interval 1))
2.1--- a/emacs/lib/ulang.el Sat Aug 10 01:40:23 2024 -0400
2.2+++ b/emacs/lib/ulang.el Sun Aug 11 01:53:06 2024 -0400
2.3@@ -26,8 +26,10 @@
2.4 ;;; Code:
2.5 (require 'org)
2.6 (require 'ox)
2.7+
2.8 (defvar ulang-links-history nil)
2.9 (defvar ulang-files-history nil)
2.10+
2.11 ;;;###autoload
2.12 (defun ulang-dblock-insert-links (regexp)
2.13 "Create dblock to insert links matching REGEXP."
2.14@@ -39,26 +41,7 @@
2.15
2.16 (org-dynamic-block-define "links" 'ulang-dblock-insert-links)
2.17
2.18-(org-export-translate-to-lang (list '("Table of Contents" "☰")) "ulang")
2.19-
2.20-(cl-pushnew '("header" .
2.21- "#+TITLE: $1
2.22-#+AUTHOR: $2
2.23-#+EMAIL: $3
2.24-#+DESCRIPTION: $4
2.25-#+SUBTITLE: $4
2.26-#+OPTIONS: ^:nil toc:nil num:nil
2.27-#+HTML_HEAD: <link href='https://fonts.googleapis.com/css?family=Inria Serif' rel='stylesheet'>
2.28-#+HTML_HEAD: <link rel=\"stylesheet\" type=\"text/css\" href=\"https://cdn.compiler.company/font/inter.css\"/>
2.29-#+HTML_HEAD: <link rel=\"stylesheet\" type=\"text/css\" href=\"https://cdn.compiler.company/font/commit-mono.css\"/>
2.30-#+HTML_HEAD: <link rel=\"stylesheet\" type=\"text/css\" href=\"https://cdn.compiler.company/css/new.min.css\"/>
2.31-#+HTML_HEAD: <link rel=\"stylesheet\" type=\"text/css\" href=\"https://cdn.compiler.company/css/night.css\"/>
2.32-")
2.33- org-export-global-macros)
2.34-
2.35-(cl-pushnew '("opts" . "#+OPTIONS: $1
2.36-")
2.37- org-export-global-macros)
2.38+(org-export-translate-to-lang (list '("Table of Contents" "TOC")) "ulang")
2.39
2.40 (setq org-link-abbrev-alist
2.41 '(("vc" . "https://vc.compiler.company/%s")
3.1--- a/lisp/ffi/readline/readline.asd Sat Aug 10 01:40:23 2024 -0400
3.2+++ b/lisp/ffi/readline/readline.asd Sun Aug 11 01:53:06 2024 -0400
3.3@@ -1,10 +1,13 @@
3.4 ;;; readline.asd --- GNU Readline FFI bindings
3.5
3.6-;;
3.7+;; GNU Readline for Lisp REPLs
3.8
3.9 ;;; Commentary:
3.10
3.11-;;
3.12+;; It is important to support a solid shell-in-shell experience in our user
3.13+;; applications. While we always have the option to build a more interactive
3.14+;; native Lisp REPL solution, GNU Readline is the defacto standard and
3.15+;; designed to handle many of the tricky OS-specific bits for us.
3.16
3.17 ;;; Code:
3.18 (defsystem :readline
4.1--- a/lisp/lib/cli/pkg.lisp Sat Aug 10 01:40:23 2024 -0400
4.2+++ b/lisp/lib/cli/pkg.lisp Sun Aug 11 01:53:06 2024 -0400
4.3@@ -81,7 +81,8 @@
4.4 :finish-progress-display
4.5 :progress-mutex
4.6 :uncertain-size-progress-bar
4.7- :progress-bar))
4.8+ :progress-bar
4.9+ :with-progress-maybe))
4.10
4.11 (defpackage :cli/spark
4.12 (:use :cl :std)
5.1--- a/lisp/lib/cli/progress.lisp Sat Aug 10 01:40:23 2024 -0400
5.2+++ b/lisp/lib/cli/progress.lisp Sun Aug 11 01:53:06 2024 -0400
5.3@@ -200,3 +200,9 @@
5.4 (prog1 (progn ,@body)
5.5 (unless (eq ,!old-bar *progress-bar*)
5.6 (finish-progress-display *progress-bar*))))))
5.7+
5.8+(defmacro with-progress-maybe (enabled (steps-count description &rest desc-args) &body body)
5.9+ (declare (ignorable steps-count description desc-args))
5.10+ (if enabled
5.11+ `(with-progress-bar (,steps-count ,description ,@desc-args) ,@body)
5.12+ `(progn ,@body)))
6.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2+++ b/lisp/lib/net/condition.lisp Sun Aug 11 01:53:06 2024 -0400
6.3@@ -0,0 +1,18 @@
6.4+;;; net/condition.lisp --- Network Conditions
6.5+
6.6+;; Generic network condition handling for Lisp.
6.7+
6.8+;;; Code:
6.9+(in-package :net/core)
6.10+
6.11+(define-condition net-condition () ())
6.12+(define-condition codec-condition (net-condition) ())
6.13+(define-condition protocol-condition (net-condition) ())
6.14+
6.15+(define-condition net-error (net-condition std-error) ())
6.16+
6.17+(define-condition codec-error (codec-condition net-error) ())
6.18+(define-condition protocol-error (protocol-condition net-error) ())
6.19+
6.20+;; sb-bsd-sockets:socket-error
6.21+;; sb-thread:thread-error
7.1--- a/lisp/lib/net/err.lisp Sat Aug 10 01:40:23 2024 -0400
7.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
7.3@@ -1,18 +0,0 @@
7.4-;;; net/err.lisp --- Network Errors
7.5-
7.6-;;
7.7-
7.8-;;; Code:
7.9-(in-package :net/core)
7.10-
7.11-(define-condition net-condition () ())
7.12-(define-condition codec-condition (net-condition) ())
7.13-(define-condition protocol-condition (net-condition) ())
7.14-
7.15-(define-condition net-error (net-condition std-error) ())
7.16-
7.17-(define-condition codec-error (codec-condition net-error) ())
7.18-(define-condition protocol-error (protocol-condition net-error) ())
7.19-
7.20-;; sb-bsd-sockets:socket-error
7.21-;; sb-thread:thread-error
8.1--- a/lisp/lib/net/fetch.lisp Sat Aug 10 01:40:23 2024 -0400
8.2+++ b/lisp/lib/net/fetch.lisp Sun Aug 11 01:53:06 2024 -0400
8.3@@ -1,11 +1,21 @@
8.4+;;; net/fetch.lisp --- Simple HTTP Downloads
8.5+
8.6+;; Provides the DOWNLOAD and FETCH functions for easily download remote files.
8.7+
8.8+;;; Commentary:
8.9+
8.10+;;; Code:
8.11 (in-package :net/fetch)
8.12
8.13 (define-condition invalid-path-error (error)
8.14 ((text :initarg :text :reader text)))
8.15
8.16-(defun download (url &key (output (obj/uri:uri-path (obj/uri:uri url)))
8.17+(defvar *default-fetch-output-file* #P"index.html")
8.18+
8.19+(defun download (url &key (output (or (obj/uri:uri-path (obj/uri:uri url)) *default-fetch-output-file*))
8.20 (if-exists :error) (progress nil) (connect-timeout net/req:*default-connect-timeout*)
8.21 cookies)
8.22+ "Download a file from URL to OUTPUT."
8.23 (let ((*progress-bar-enabled* progress))
8.24 (multiple-value-bind (stream status header uri)
8.25 (req:get url :want-stream t :force-binary t :connect-timeout connect-timeout :verbose (log:trace-p)
8.26@@ -13,16 +23,18 @@
8.27 (when (= status 200)
8.28 (log:debug! "download connect OK:" url)
8.29 (log:debug! "headers:" (hash-table-alist header))
8.30- (let ((len (gethash "content-length" header)))
8.31+ (let ((len (gethash "content-length" header))
8.32+ (buff (make-array 4096 :element-type 'octet :adjustable t)))
8.33 (when len (setf len (parse-integer len)))
8.34- (with-progress-bar (len "downloading ~a to ~a..." url output)
8.35- (with-open-file (out output :direction :output :element-type '(unsigned-byte 8) :if-exists if-exists)
8.36- (loop for c = (read-byte stream nil nil)
8.37- while c
8.38- do (progn
8.39- (update-progress *progress-bar* 1)
8.40- (write-byte c out)))))
8.41- (values stream status uri header))))))
8.42+ (with-progress-maybe progress (len "downloading ~a to ~a..." url output)
8.43+ (with-open-file (out output :direction :output :element-type 'octet :if-exists if-exists)
8.44+ (loop
8.45+ (let ((end (read-sequence buff stream :end 4096)))
8.46+ (when progress (update-progress *progress-bar* end))
8.47+ (write-sequence buff out :end end)
8.48+ (unless (= end 4096)
8.49+ (return))))))))
8.50+ (values stream status uri header))))
8.51
8.52 (defun split-file-path (path)
8.53 (let ((pos-last-slash (1+ (position #\/ path :from-end t))))
8.54@@ -61,28 +73,28 @@
8.55 (download url-or-path :output file-pathname)))))
8.56 (t (values nil 404 "Not file of url"))))
8.57
8.58-(defun fetch (url-or-path
8.59+(defun fetch (url
8.60 &key
8.61 (dir)
8.62 (external-format :utf-8)
8.63 (cache t)
8.64 (stream nil)
8.65 (flush nil))
8.66- "Fetch file from ~url-or-location~ if not cached in ~dir~
8.67+ "Fetch file from URL if not cached in DIR
8.68 stores the file in the location specified by dir if url or file is url the file
8.69-is stored in ~dir~/~uri-host~/~uri-path~.
8.70+is stored in DIR/URI-HOST/URI-PATH.
8.71
8.72 Note that it is important to ensure that dir and subdir if used end in a /
8.73
8.74 -return: path to file or stream if :stream parameter is passed
8.75 -arguments:
8.76- - url-or-path: <string> pathname or url string identifying file to be fetched.
8.77+ - url: <string> pathname or url string identifying file to be fetched.
8.78 - stream: resuests that fetch returns a stream
8.79 - cache: <T|NIL> if T looks for file in -dir and uses that as source if NIL then the a fresh copy of the file is fetched
8.80 - dir: location to store fetched file.
8.81 - flush: if T fetch does not download the file it deletes the existing file.
8.82 "
8.83- (let ((fetched-path (%fetch url-or-path :dir dir :cache cache :flush flush)))
8.84+ (let ((fetched-path (%fetch url :dir dir :cache cache :flush flush)))
8.85 (if (not fetched-path)
8.86 nil
8.87 (if stream
9.1--- a/lisp/lib/net/net.asd Sat Aug 10 01:40:23 2024 -0400
9.2+++ b/lisp/lib/net/net.asd Sun Aug 11 01:53:06 2024 -0400
9.3@@ -15,7 +15,7 @@
9.4 :std :log)
9.5 :serial t
9.6 :components ((:file "pkg")
9.7- (:file "err")
9.8+ (:file "condition")
9.9 (:file "obj")
9.10 (:file "util")
9.11 (:file "udp")
10.1--- a/lisp/lib/net/pkg.lisp Sat Aug 10 01:40:23 2024 -0400
10.2+++ b/lisp/lib/net/pkg.lisp Sun Aug 11 01:53:06 2024 -0400
10.3@@ -349,6 +349,7 @@
10.4 :net/core
10.5 :net/tcp
10.6 :net/udp
10.7+ :net/srv
10.8 :net/codec/dns
10.9 :net/codec/osc
10.10 :net/codec/tlv
11.1--- a/lisp/lib/net/tests.lisp Sat Aug 10 01:40:23 2024 -0400
11.2+++ b/lisp/lib/net/tests.lisp Sun Aug 11 01:53:06 2024 -0400
11.3@@ -1,5 +1,5 @@
11.4 (defpackage :net/tests
11.5- (:use :rt :std :cl :net :sb-concurrency :sb-thread :dat/proto))
11.6+ (:use :rt :std :cl :net :sb-concurrency :sb-thread :dat/proto :sb-bsd-sockets))
11.7
11.8 (in-package :net/tests)
11.9
11.10@@ -14,11 +14,15 @@
11.11
11.12 (deftest tcp ()
11.13 (with-tcp-client (client)
11.14- (is (typep client 'sb-bsd-sockets:inet-socket))))
11.15+ (is (typep client 'sb-bsd-sockets:inet-socket))
11.16+ (is (= (get-protocol-by-name :tcp)
11.17+ (socket-protocol client)))))
11.18
11.19 (deftest udp ()
11.20 (with-udp-client (client)
11.21- (is (typep client 'sb-bsd-sockets:inet-socket))))
11.22+ (is (typep client 'sb-bsd-sockets:inet-socket))
11.23+ (is (= (get-protocol-by-name :udp)
11.24+ (socket-protocol client)))))
11.25
11.26 (deftest tlv ()
11.27 (is (= 4 (length (serialize (make-instance 'tlv :type 0 :length 1 :value #(1)) :bytes)))))
11.28@@ -48,7 +52,7 @@
11.29 (is (req:get (uri:uri "https://compiler.company/index.html"))))
11.30
11.31 (deftest fetch ()
11.32- (is (fetch:download "https://compiler.company/index.html" "/tmp/index.html"))
11.33+ (is (fetch:download "https://compiler.company/index.html" :output "/tmp/index.html" :progress t))
11.34 (is (delete-file "/tmp/index.html")))
11.35
11.36 (deftest cookies ()
11.37@@ -61,4 +65,4 @@
11.38
11.39
11.40 (deftest srv ()
11.41- (is (pathnamep (net/srv:default-web-directory))))
11.42+ (is (pathnamep (default-web-directory))))
12.1--- a/lisp/lib/obj/query.lisp Sat Aug 10 01:40:23 2024 -0400
12.2+++ b/lisp/lib/obj/query.lisp Sun Aug 11 01:53:06 2024 -0400
12.3@@ -819,17 +819,30 @@
12.4
12.5 ;; Rule-based Optimizers: projection/predicate push-down, sub-expr elim
12.6
12.7+;; Lowerings: hdsl -> ldsl
12.8+
12.9+;; Extensibility principle - A low level DSL should have greater than or equal
12.10+;; to expressiveness of a high level DSL
12.11+
12.12+;; Transformation cohesion principle - There should be a unique path lowering
12.13+;; a high-level DSL to a low-level DSL. This also prevents loops between high
12.14+;; and low level DSLs.
12.15+
12.16 ;; TBD: Cost-based optimizers
12.17 ;; TODO 2024-07-10:
12.18 (defclass query-optimizer () ())
12.19
12.20 (defstruct (query-vop (:constructor make-query-vop (info)))
12.21+ "A virtual query operation available to query compilers."
12.22 (info nil))
12.23
12.24-(defgeneric optimize-query (self plan))
12.25+(defgeneric optimize-query (self plan)
12.26+ (:documentation "Optimize the query expressed by PLAN using the optimizer SELF."))
12.27
12.28 ;; Projection Pushdown
12.29 (defun extract-columns (expr input &optional accum)
12.30+ "Recursively check an expression for field indicators and add the to an
12.31+accumulator."
12.32 (etypecase expr
12.33 (array-index (accumulate accum (field (fields (schema input)) expr)))
12.34 (column-expression (accumulate accum (column-name expr)))
12.35@@ -878,6 +891,7 @@
12.36 (defclass query () ())
12.37
12.38 (defgeneric make-query (self &rest initargs &key &allow-other-keys)
12.39+ (:documentation "Make a new QUERY object.")
12.40 (:method ((self t) &rest initargs)
12.41 (declare (ignore initargs))
12.42 (make-instance 'query)))
12.43@@ -895,7 +909,7 @@
12.44 (:documentation "Register a DATA-SOURCE contained in a file of type TYPE at PATH."))
12.45
12.46 (defgeneric execute* (self df)
12.47- (:documentation "Execute the DATA-FRAME DF in CONTEXT.")
12.48+ (:documentation "Execute the DATA-FRAME DF in CONTEXT. This is the stateful version of EXECUTE.")
12.49 (:method ((self execution-context) (df data-frame))
12.50 (declare (ignore self))
12.51 (execute df)))
13.1--- a/lisp/lib/q/tests/suite.lisp Sat Aug 10 01:40:23 2024 -0400
13.2+++ b/lisp/lib/q/tests/suite.lisp Sun Aug 11 01:53:06 2024 -0400
13.3@@ -47,40 +47,16 @@
13.4 (adjacent 4 3)
13.5 (adjacent 4 5)
13.6 (adjacent 5 4)
13.7- (color 1 red a) (color 1 red b)
13.8- (color 2 blue a) (color 2 blue b)
13.9- (color 3 green a) (color 3 green b)
13.10- (color 4 yellow a) (color 4 blue b)
13.11- (color 5 blue a) (color 5 green b)
13.12-
13.13- (:- (conflict ?coloring)
13.14- (adjacent ?x ?y)
13.15- (color ?x ?color ?coloring)
13.16- (color ?y ?color ?coloring))
13.17-
13.18-
13.19- (:- (conflict ?r1 ?r2 ?coloring)
13.20- (adjacent ?r1 ?r2)
13.21- (color ?r1 ?color ?coloring)
13.22- (color ?r2 ?color ?coloring))
13.23-
13.24-
13.25- ;; there are several infix operators.
13.26- ;; :- , >, <, -> etc.
13.27- ;; let's mark variables with ? prefix.
13.28- ;;
13.29-
13.30- (:- main
13.31- (forall (conflict ?coloring)
13.32- (writeln (conflict ?coloring)))
13.33- (forall (conflict ?r1 ?r2 ?coloring)
13.34- (writeln (conflict ?r1 ?r2 ?coloring)))
13.35- (forall (conflict ?r1 ?r2 ?coloring)
13.36- (and (print-sexp (conflict ?r1 ?r2 ?coloring))
13.37- nl))
13.38- halt)
13.39-
13.40- (:- (initialization main)))
13.41+ (color 1 red a)
13.42+ (color 1 red b)
13.43+ (color 2 blue a)
13.44+ (color 2 blue b)
13.45+ (color 3 green a)
13.46+ (color 3 green b)
13.47+ (color 4 yellow a)
13.48+ (color 4 blue b)
13.49+ (color 5 blue a)
13.50+ (color 5 green b))
13.51
13.52 #| SL
13.53 Exercise 2.9. Translate to clausal logic:
14.1--- a/lisp/std/pkg.lisp Sat Aug 10 01:40:23 2024 -0400
14.2+++ b/lisp/std/pkg.lisp Sun Aug 11 01:53:06 2024 -0400
14.3@@ -441,6 +441,8 @@
14.4 :current-lisp-implementation
14.5 :current-machine
14.6 :list-package-symbols
14.7+ :package-symbols
14.8+ :package-symbol-names
14.9 :append-logical-hosts
14.10 :save-lisp-tree-shake-and-die
14.11 :save-lisp-and-live
15.1--- a/lisp/std/sys.lisp Sat Aug 10 01:40:23 2024 -0400
15.2+++ b/lisp/std/sys.lisp Sun Aug 11 01:53:06 2024 -0400
15.3@@ -36,6 +36,23 @@
15.4 (loop for s being the external-symbol of pkg
15.5 collect s))
15.6
15.7+(defun package-symbols (&optional (package *package*) test)
15.8+ (let ((symbols))
15.9+ (do-external-symbols (symbol package)
15.10+ (if test
15.11+ (when (funcall test symbol)
15.12+ (push symbol symbols))
15.13+ (push symbol symbols)))
15.14+ symbols))
15.15+
15.16+(defun package-symbol-names (&optional (package *package*) test)
15.17+ (sort (mapcar (lambda (x) (string-downcase (symbol-name x)))
15.18+ (package-symbols package test))
15.19+ #'string<))
15.20+
15.21+(defun standard-symbol-names (test)
15.22+ (package-symbol-names :common-lisp test))
15.23+
15.24 (defun append-logical-hosts (&rest hosts)
15.25 "Reinitialize SB-IMPL::*LOGICAL-HOSTS* with a freshly allocated vector
15.26 consisting of the old contents appended to the new."
15.27@@ -81,8 +98,6 @@
15.28 (defun enable-gc-logfile (&optional (file *gc-logfile*))
15.29 (setf (sb-ext:gc-logfile) file))
15.30
15.31-(length (sb-di::list-allocated-objects :dynamic :test #'stringp))
15.32-
15.33 (defun forget-shared-object (name)
15.34 (setf (sb-alien::shared-object-dont-save
15.35 (find name sb-sys:*shared-objects*
16.1--- a/skelfile Sat Aug 10 01:40:23 2024 -0400
16.2+++ b/skelfile Sun Aug 11 01:53:06 2024 -0400
16.3@@ -120,6 +120,10 @@
16.4 install -C -m 755 $f $d
16.5 done fi$#)
16.6 (emacs () #$make -C emacs$#)
16.7+ (core-syms.sxp ()
16.8+ (with-open-file (f "emacs/core-syms.sxp")
16.9+ (write `(defvar lisp-standard-function-names ,(standard-symbol-names #'fboundp)) :stream f)
16.10+ (write `(defvar lisp-standard-value-names ,(standard-symbol-names #'boundp)) :stream f)))
16.11 (dist () #$cd .stash
16.12 mkdir -pv core/bin core/share/lisp/fasl core/lib
16.13 mv *.core core/share/lisp/
