1.1--- a/lisp/bin/packy.lisp Tue May 21 17:13:34 2024 -0400
1.2+++ b/lisp/bin/packy.lisp Tue May 21 22:20:29 2024 -0400
1.3@@ -14,7 +14,7 @@
1.4 (define-cli $cli
1.5 :name "packy"
1.6 :version "0.1.0"
1.7- :description "user home manager"
1.8+ :description "Universal Package Manager"
1.9 :thunk pk-show
1.10 :opts (make-opts
1.11 (:name "level" :global t :description "set the log level" :thunk pk-log-level)
2.1--- a/lisp/lib/cli/clap.lisp Tue May 21 17:13:34 2024 -0400
2.2+++ b/lisp/lib/cli/clap.lisp Tue May 21 22:20:29 2024 -0400
2.3@@ -53,15 +53,17 @@
2.4
2.5 (defmacro with-cli (slots cli &body body)
2.6 "Like with-slots with some extra bindings."
2.7- ;; (with-gensyms (cli-body)
2.8- ;; (let ((cli-body (mapcar (lambda (x) ()) cli-body)
2.9 `(progn
2.10- (setf (cli-cwd ,cli) (sb-posix:getcwd))
2.11+ (setf (cli-cd ,cli) (sb-posix:getcwd))
2.12 (with-slots ,slots (parse-args ,cli (cli-args) :compile t)
2.13 ,@body)))
2.14
2.15 (defvar *default-cli-def* 'defparameter)
2.16
2.17+(defvar *default-cli-class* 'cli
2.18+ "The name of the class of the top-level CLI object which will be
2.19+generated by the DEFINE-CLI macro.")
2.20+
2.21 (defmacro defcmd (name &body body)
2.22 `(defun ,name ($args $opts)
2.23 (declare (ignorable $args $opts))
2.24@@ -87,8 +89,13 @@
2.25
2.26 (defmacro define-cli (name &body body)
2.27 "Define a symbol NAME bound to a top-level CLI object."
2.28- (declare (type symbol name))
2.29- `(,*default-cli-def* ,name (apply #'make-cli t (walk-cli-slots ',body))))
2.30+ (with-gensyms (%name %class)
2.31+ (if (atom name)
2.32+ (setq %name name
2.33+ %class nil)
2.34+ (setq %name (car name)
2.35+ %class (cdr name)))
2.36+ `(,*default-cli-def* ,%name (apply #'make-cli ,%class (walk-cli-slots ',body)))))
2.37
2.38 (defmacro defmain ((&key return (exit t)) &body body)
2.39 "Define a CLI main function in the current package."
2.40@@ -111,12 +118,13 @@
2.41 ((eql kind :cli) (apply #'make-instance 'cli slots))
2.42 ((eql kind :opt) (apply #'make-cli-opt slots))
2.43 ((eql kind :cmd) (apply #'make-instance 'cli-cmd slots))
2.44- (t (apply #'make-instance 'cli slots))))
2.45+ (t (apply #'make-instance kind slots))))
2.46
2.47 ;; RESEARCH 2023-09-12: closed over hash-table with short/long flags
2.48 ;; to avoid conflicts. if not, need something like a flag-function
2.49 ;; slot at class allocation.
2.50 (defmacro make-opts (&body opts)
2.51+ "Make a vector of CLI-OPTs based on OPTS."
2.52 `(map 'vector
2.53 (lambda (x)
2.54 (etypecase x
2.55@@ -125,14 +133,15 @@
2.56 (t (make-cli :opt :name (format nil "~(~A~)" x) :global t))))
2.57 (walk-cli-slots ',opts)))
2.58
2.59-(defmacro make-cmds (&body opts)
2.60+(defmacro make-cmds (&body cmds)
2.61+ "Make a vector of CLI-CMDs based on CMDS."
2.62 `(map 'vector
2.63 (lambda (x)
2.64 (etypecase x
2.65 (string (make-cli :cmd :name x))
2.66 (list (apply #'make-cli :cmd x))
2.67 (t (make-cli :cmd :name (format nil "~(~A~)" x)))))
2.68- (walk-cli-slots ',opts)))
2.69+ (walk-cli-slots ',cmds)))
2.70
2.71 (defun long-opt-p (str)
2.72 (declare (simple-string str))
2.73@@ -338,7 +347,8 @@
2.74 (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean)
2.75 (description :initarg :description :accessor cli-description :type string)
2.76 (args :initform nil :initarg :args :accessor cli-cmd-args))
2.77- (:documentation "CLI command"))
2.78+ (:documentation "CLI command class inherited by both the 'main' command which is executed when
2.79+a CLI is called without arguments, and all subcommands."))
2.80
2.81 (defmethod initialize-instance :after ((self cli-cmd) &key)
2.82 (with-slots (name cmds opts thunk) self
2.83@@ -562,7 +572,7 @@
2.84 (install-ast self args))))
2.85
2.86 ;; warning: make sure to fill in the opt and cmd slots with values
2.87-;; from the top-level args before doing a command.
2.88+;; from the top-level args before calling a command.
2.89 (defmethod call-cmd ((self cli-cmd) args opts)
2.90 (trace! args opts)
2.91 (funcall (cli-thunk self) args opts))
2.92@@ -580,8 +590,8 @@
2.93 ;; name slot defaults to *package*, must be string
2.94 ((name :initarg :name :initform (string-downcase (package-name *package*)) :accessor cli-name :type string)
2.95 (version :initarg :version :initform "0.1.0" :accessor cli-version :type string)
2.96- ;; TODO 2023-10-11: look into pushd popd - wd-stack?
2.97- (cwd :initarg :cwd :initform (sb-posix:getcwd) :type string :accessor cli-cwd
2.98+ ;; TODO 2023-10-11: look into pushd popd - cd-stack?
2.99+ (cd :initarg :cd :initform (sb-posix:getcwd) :type string :accessor cli-cd
2.100 :documentation "working directory of the top-level CLI."))
2.101 (:documentation "CLI"))
2.102
2.103@@ -620,7 +630,7 @@
2.104 (let ((o (active-opts cli))
2.105 (a (cli-cmd-args cli))
2.106 (c (active-cmds cli)))
2.107- (log:debug! (cli-cwd cli) o a c)))
2.108+ (log:debug! (cli-cd cli) o a c)))
2.109
2.110 ;;; SIMPLE-CLI
2.111
2.112@@ -663,6 +673,14 @@
2.113 (setf (cdr *posix-argv*) opts))
2.114 ,@body))))
2.115
2.116+;;; TOPLEVEL
2.117+
2.118+;; These macros help with defining a toplevel initialization
2.119+;; function. Initialization functions are responsible for parsing runtime
2.120+;; options and starting a REPL if needed.
2.121+;; (defmacro define-toplevel-init (name (props opts) &body body))
2.122+;; (defmacro define-toplevel-repl (name (props opts) &body body))
2.123+
2.124 (defun default-toplevel-init ()
2.125 (let ((opts (cdr *posix-argv*))
2.126 (sysinit))
2.127@@ -687,11 +705,3 @@
2.128 (return))))))
2.129 (when *posix-argv*
2.130 (setf (cdr *posix-argv*) opts)))))
2.131-
2.132-;;; TOPLEVEL
2.133-
2.134-;; These macros help with defining a toplevel initialization
2.135-;; function. Initialization functions are responsible for parsing runtime
2.136-;; options and starting a REPL if needed.
2.137-;; (defmacro define-toplevel-init (name (props opts) &body body))
2.138-;; (defmacro define-toplevel-repl (name (props opts) &body body))
3.1--- a/lisp/lib/cli/pkg.lisp Tue May 21 17:13:34 2024 -0400
3.2+++ b/lisp/lib/cli/pkg.lisp Tue May 21 22:20:29 2024 -0400
3.3@@ -163,7 +163,7 @@
3.4 :cli-val
3.5 :cli-cmd-args
3.6 :cli-cmd
3.7- :cli-cwd
3.8+ :cli-cd
3.9 :find-cmd
3.10 :find-opt
3.11 :find-short-opt
4.1--- a/lisp/lib/io/io.asd Tue May 21 17:13:34 2024 -0400
4.2+++ b/lisp/lib/io/io.asd Tue May 21 22:20:29 2024 -0400
4.3@@ -3,7 +3,8 @@
4.4 :depends-on (:cl-ppcre :std :obj :uring :sb-bsd-sockets)
4.5 :version "0.1.0"
4.6 :serial t
4.7- :components ((:file "pkg"))
4.8+ :components ((:file "pkg")
4.9+ (:file "xsubseq"))
4.10 :in-order-to ((test-op (test-op "io/tests"))))
4.11
4.12 (defsystem :io/tests
5.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2+++ b/lisp/lib/io/xsubseq.lisp Tue May 21 22:20:29 2024 -0400
5.3@@ -0,0 +1,286 @@
5.4+;;; io/xsubseq.lisp --- Subseq Optimizations
5.5+
5.6+;; This is ported from Fukamachi's XSUBSEQ
5.7+
5.8+;;; Code:
5.9+(defpackage io/xsubseq
5.10+ (:use :cl)
5.11+ (:import-from :sb-cltl2 :variable-information)
5.12+ (:import-from :std/type :octet-vector)
5.13+ (:export :xsubseq
5.14+ :octet-xsubseq
5.15+ :string-xsubseq
5.16+ :concatenated-xsubseqs
5.17+ :null-concatenated-xsubseqs
5.18+ :octet-concatenated-xsubseqs
5.19+ :string-concatenated-xsubseqs
5.20+ :make-concatenated-xsubseqs
5.21+ :xlength
5.22+ :xnconc
5.23+ :xnconcf
5.24+ :coerce-to-sequence
5.25+ :coerce-to-string
5.26+ :with-xsubseqs))
5.27+(in-package :io/xsubseq)
5.28+
5.29+(defstruct (xsubseq (:constructor make-xsubseq (data start &optional (end (length data))
5.30+ &aux (len (- end start)))))
5.31+ (data nil)
5.32+ (start 0 :type integer)
5.33+ (end 0 :type integer)
5.34+ (len 0 :type integer))
5.35+
5.36+(defstruct (octet-xsubseq (:include xsubseq)
5.37+ (:constructor make-octet-xsubseq (data start &optional (end (length data))
5.38+ &aux (len (- end start))))))
5.39+
5.40+(defstruct (string-xsubseq (:include xsubseq)
5.41+ (:constructor make-string-xsubseq (data start &optional (end (length data))
5.42+ &aux (len (- end start))))))
5.43+
5.44+(defstruct (concatenated-xsubseqs (:constructor %make-concatenated-xsubseqs))
5.45+ (len 0 :type integer)
5.46+ (last nil :type list)
5.47+ (children nil :type list))
5.48+
5.49+(defun make-concatenated-xsubseqs (&rest children)
5.50+ (if (null children)
5.51+ (make-null-concatenated-xsubseqs)
5.52+ (%make-concatenated-xsubseqs :children children
5.53+ :last (last children)
5.54+ :len (reduce #'+
5.55+ children
5.56+ :key #'xsubseq-len
5.57+ :initial-value 0))))
5.58+
5.59+(defstruct (null-concatenated-xsubseqs (:include concatenated-xsubseqs)))
5.60+
5.61+(defstruct (octet-concatenated-xsubseqs (:include concatenated-xsubseqs)))
5.62+
5.63+(defstruct (string-concatenated-xsubseqs (:include concatenated-xsubseqs)))
5.64+
5.65+(defun xsubseq (data start &optional (end (length data)))
5.66+ (typecase data
5.67+ (octet-vector (make-octet-xsubseq data start end))
5.68+ (string (make-string-xsubseq data start end))
5.69+ (t (make-xsubseq data start end))))
5.70+
5.71+#+(or sbcl openmcl cmu allegro)
5.72+(define-compiler-macro xsubseq (&whole form &environment env data start &optional end)
5.73+ (let ((type (cond
5.74+ ((constantp data) (type-of data))
5.75+ ((and (symbolp data)
5.76+ (assoc 'type (nth-value 2 (variable-information data env)))))
5.77+ ((and (listp data)
5.78+ (eq (car data) 'make-string))
5.79+ 'string)
5.80+ ((and (listp data)
5.81+ (eq (car data) 'the)
5.82+ (cadr data)))
5.83+ ((and (listp data)
5.84+ (eq (car data) 'make-array)
5.85+ (null (cadr (member :adjustable data)))
5.86+ (null (cadr (member :fill-pointer data)))
5.87+ (cadr (member :element-type data))))))
5.88+ (g-data (gensym "DATA")))
5.89+ (if (null type)
5.90+ form
5.91+ (cond
5.92+ ((subtypep type 'octet-vector) `(let ((,g-data ,data))
5.93+ (make-octet-xsubseq ,g-data ,start ,(or end `(length ,g-data)))))
5.94+ ((subtypep type 'string) `(let ((,g-data ,data))
5.95+ (make-string-xsubseq ,g-data ,start ,(or end `(length ,g-data)))))
5.96+ (t form)))))
5.97+
5.98+(defun %xnconc2 (seq1 seq2)
5.99+ (flet ((seq-values (seq)
5.100+ (if (concatenated-xsubseqs-p seq)
5.101+ (values (concatenated-xsubseqs-children seq)
5.102+ (concatenated-xsubseqs-last seq)
5.103+ (concatenated-xsubseqs-len seq))
5.104+ (let ((children (list seq)))
5.105+ (values children children
5.106+ (xsubseq-len seq))))))
5.107+ (macrolet ((make-concatenated (type seq1 seq2)
5.108+ `(multiple-value-bind (children last len)
5.109+ (seq-values ,seq2)
5.110+ (,(cond
5.111+ ((eq type 'octet-vector) 'make-octet-concatenated-xsubseqs)
5.112+ ((eq type 'string) 'make-string-concatenated-xsubseqs)
5.113+ (t '%make-concatenated-xsubseqs))
5.114+ :len (+ (xsubseq-len ,seq1) len)
5.115+ :children (cons ,seq1 children)
5.116+ :last last))))
5.117+ (etypecase seq1
5.118+ (null-concatenated-xsubseqs seq2)
5.119+ (concatenated-xsubseqs
5.120+ (multiple-value-bind (children last len)
5.121+ (seq-values seq2)
5.122+ (if (concatenated-xsubseqs-last seq1)
5.123+ (progn
5.124+ (rplacd (concatenated-xsubseqs-last seq1)
5.125+ children)
5.126+ (setf (concatenated-xsubseqs-last seq1) last)
5.127+ (incf (concatenated-xsubseqs-len seq1) len))
5.128+ ;; empty concatenated-xsubseqs
5.129+ (progn
5.130+ (setf (concatenated-xsubseqs-children seq1) children
5.131+ (concatenated-xsubseqs-len seq1) len
5.132+ (concatenated-xsubseqs-last seq1) last)))
5.133+ seq1))
5.134+ (octet-xsubseq
5.135+ (make-concatenated octet-vector seq1 seq2))
5.136+ (string-xsubseq
5.137+ (make-concatenated string seq1 seq2))
5.138+ (xsubseq (make-concatenated t seq1 seq2))))))
5.139+
5.140+(defun xnconc (subseq &rest more-subseqs)
5.141+ (reduce #'%xnconc2 more-subseqs :initial-value subseq))
5.142+
5.143+(define-modify-macro xnconcf (subseq &rest more-subseqs) xnconc)
5.144+
5.145+(defun xlength (seq)
5.146+ (etypecase seq
5.147+ (xsubseq (xsubseq-len seq))
5.148+ (concatenated-xsubseqs (concatenated-xsubseqs-len seq))))
5.149+
5.150+(defun coerce-to-sequence (seq)
5.151+ (etypecase seq
5.152+ (octet-concatenated-xsubseqs (octet-concatenated-xsubseqs-to-sequence seq))
5.153+ (string-concatenated-xsubseqs (string-concatenated-xsubseqs-to-sequence seq))
5.154+ (concatenated-xsubseqs (concatenated-xsubseqs-to-sequence seq))
5.155+ (xsubseq (xsubseq-to-sequence seq))))
5.156+
5.157+#+(or sbcl openmcl cmu allegro)
5.158+(define-compiler-macro coerce-to-sequence (&whole form &environment env seq)
5.159+ (let ((type (cond
5.160+ ((constantp seq) (type-of seq))
5.161+ ((and (symbolp seq)
5.162+ (assoc 'type (nth-value 2 (variable-information seq env)))))
5.163+ ((and (listp seq)
5.164+ (eq (car seq) 'the)
5.165+ (cadr seq))))))
5.166+ (if (null type)
5.167+ form
5.168+ (cond
5.169+ ((subtypep type 'octet-concatenated-xsubseqs) `(octet-concatenated-xsubseqs-to-sequence ,seq))
5.170+ ((subtypep type 'string-concatenated-xsubseqs) `(string-concatenated-xsubseqs-to-sequence ,seq))
5.171+ ((subtypep type 'concatenated-xsubseqs) `(concatenated-xsubseqs-to-sequence ,seq))
5.172+ ((subtypep type 'xsubseq) `(xsubseq-to-sequence ,seq))
5.173+ (t form)))))
5.174+
5.175+(defun coerce-to-string (seq)
5.176+ (etypecase seq
5.177+ (null-concatenated-xsubseqs "")
5.178+ (octet-concatenated-xsubseqs (octet-concatenated-xsubseqs-to-string seq))
5.179+ (string-concatenated-xsubseqs (string-concatenated-xsubseqs-to-sequence seq))
5.180+ (octet-xsubseq (octet-xsubseq-to-string seq))
5.181+ (string-xsubseq (xsubseq-to-sequence seq))))
5.182+
5.183+#+(or sbcl openmcl cmu allegro)
5.184+(define-compiler-macro coerce-to-string (&whole form &environment env seq)
5.185+ (let ((type (cond
5.186+ ((constantp seq) (type-of seq))
5.187+ ((and (symbolp seq)
5.188+ (assoc 'type (nth-value 2 (variable-information seq env)))))
5.189+ ((and (listp seq)
5.190+ (eq (car seq) 'the)
5.191+ (cadr seq))))))
5.192+ (if (null type)
5.193+ form
5.194+ (cond
5.195+ ((subtypep type 'octet-concatenated-xsubseqs) `(octet-concatenated-xsubseqs-to-string ,seq))
5.196+ ((subtypep type 'string-concatenated-xsubseqs) `(string-concatenated-xsubseqs-to-sequence ,seq))
5.197+ ((subtypep type 'octet-xsubseq) `(octet-xsubseq-to-string ,seq))
5.198+ ((subtypep type 'string-xsubseq) `(xsubseq-to-sequence ,seq))
5.199+ (t form)))))
5.200+
5.201+(defun xsubseq-to-sequence (seq)
5.202+ (let ((result (make-array (xsubseq-len seq)
5.203+ :element-type
5.204+ (array-element-type (xsubseq-data seq)))))
5.205+ (replace result (xsubseq-data seq)
5.206+ :start2 (xsubseq-start seq)
5.207+ :end2 (xsubseq-end seq))
5.208+ result))
5.209+
5.210+(defun octet-xsubseq-to-string (seq)
5.211+ (let ((result (make-array (xsubseq-len seq)
5.212+ :element-type 'character)))
5.213+ (declare (type simple-string result))
5.214+ (let ((data (xsubseq-data seq))
5.215+ (end (xsubseq-end seq)))
5.216+ (do ((i (xsubseq-start seq) (1+ i))
5.217+ (j 0 (1+ j)))
5.218+ ((= i end) result)
5.219+ (setf (aref result j)
5.220+ (code-char
5.221+ (the (unsigned-byte 8)
5.222+ (aref (the octet-vector data) i))))))))
5.223+
5.224+(defun concatenated-xsubseqs-to-sequence (seq)
5.225+ (let ((result (make-array (concatenated-xsubseqs-len seq)
5.226+ :element-type
5.227+ (array-element-type (xsubseq-data (car (concatenated-xsubseqs-children seq)))))))
5.228+ (loop with current-pos = 0
5.229+ for seq in (concatenated-xsubseqs-children seq)
5.230+ do (replace result (xsubseq-data seq)
5.231+ :start1 current-pos
5.232+ :start2 (xsubseq-start seq)
5.233+ :end2 (xsubseq-end seq))
5.234+ (incf current-pos
5.235+ (xsubseq-len seq)))
5.236+ result))
5.237+
5.238+(defun octet-concatenated-xsubseqs-to-sequence (seq)
5.239+ (let ((result (make-array (concatenated-xsubseqs-len seq)
5.240+ :element-type '(unsigned-byte 8))))
5.241+ (declare (type octet-vector result))
5.242+ (loop with current-pos of-type integer = 0
5.243+ for seq in (concatenated-xsubseqs-children seq)
5.244+ do (replace result (the octet-vector (xsubseq-data seq))
5.245+ :start1 current-pos
5.246+ :start2 (xsubseq-start seq)
5.247+ :end2 (xsubseq-end seq))
5.248+ (incf current-pos
5.249+ (xsubseq-len seq)))
5.250+ result))
5.251+
5.252+(defun octet-concatenated-xsubseqs-to-string (seq)
5.253+ (let ((result (make-array (concatenated-xsubseqs-len seq)
5.254+ :element-type 'character)))
5.255+ (declare (type simple-string result))
5.256+ (loop with current-pos = 0
5.257+ for seq in (concatenated-xsubseqs-children seq)
5.258+ do (do ((i (xsubseq-start seq) (1+ i))
5.259+ (j current-pos (1+ j)))
5.260+ ((= i (xsubseq-end seq))
5.261+ (setf current-pos j))
5.262+ (setf (aref result j)
5.263+ (code-char
5.264+ (the (unsigned-byte 8)
5.265+ (aref (the octet-vector (xsubseq-data seq)) i))))))
5.266+ result))
5.267+
5.268+(defun string-concatenated-xsubseqs-to-sequence (seq)
5.269+ (let ((result (make-string (concatenated-xsubseqs-len seq))))
5.270+ (declare (type simple-string result))
5.271+ (loop with current-pos of-type integer = 0
5.272+ for seq in (concatenated-xsubseqs-children seq)
5.273+ do (replace result (the simple-string (xsubseq-data seq))
5.274+ :start1 current-pos
5.275+ :start2 (xsubseq-start seq)
5.276+ :end2 (xsubseq-end seq))
5.277+ (incf current-pos
5.278+ (xsubseq-len seq)))
5.279+ result))
5.280+
5.281+(defmacro with-xsubseqs ((xsubseqs &key initial-value) &body body)
5.282+ `(let ((,xsubseqs ,(or initial-value
5.283+ `(make-null-concatenated-xsubseqs))))
5.284+ ,@body
5.285+
5.286+ (typecase ,xsubseqs
5.287+ (null-concatenated-xsubseqs nil)
5.288+ (xsubseq (xsubseq-to-sequence ,xsubseqs))
5.289+ (t (concatenated-xsubseqs-to-sequence ,xsubseqs)))))
6.1--- a/lisp/lib/net/pkg.lisp Tue May 21 17:13:34 2024 -0400
6.2+++ b/lisp/lib/net/pkg.lisp Tue May 21 22:20:29 2024 -0400
6.3@@ -156,7 +156,7 @@
6.4 (:export))
6.5
6.6 (defpackage :net/proto/http
6.7- (:use :cl :std :net/core :sb-bsd-sockets)
6.8+ (:use :cl :std :net/core :sb-bsd-sockets :parse/bytes)
6.9 (:export))
6.10
6.11 (uiop:define-package :net/fetch
7.1--- a/lisp/lib/net/proto/http.lisp Tue May 21 17:13:34 2024 -0400
7.2+++ b/lisp/lib/net/proto/http.lisp Tue May 21 22:20:29 2024 -0400
7.3@@ -196,10 +196,9 @@
7.4 (when header-value-buffer
7.5 (let ((header-value
7.6 (locally (declare (optimize (speed 3) (safety 0)))
7.7- (coerce-to-string
7.8- (the (or octets-concatenated-xsubseqs
7.9- octets-xsubseq)
7.10- header-value-buffer)))))
7.11+ (coerce
7.12+ header-value-buffer
7.13+ 'string))))
7.14 (if (string= parsing-header-field "set-cookie")
7.15 (push header-value (gethash "set-cookie" headers))
7.16 (multiple-value-bind (previous-value existp)
7.17@@ -318,6 +317,257 @@
7.18 (when parsing-boundary
7.19 (return-from find-boundary (subseq data start end)))))))
7.20
7.21+;;; multipart-parser
7.22+(defstruct (ll-multipart-parser (:constructor make-ll-multipart-parser
7.23+ (&key boundary
7.24+ &aux (header-parser
7.25+ (let ((parser (make-http)))
7.26+ (setf (http-state parser) +state-headers+)
7.27+ parser)))))
7.28+ (state 0 :type fixnum)
7.29+ (header-parser)
7.30+ boundary
7.31+ body-mark
7.32+ body-buffer
7.33+ boundary-mark
7.34+ boundary-buffer)
7.35+
7.36+#.`(eval-when (:compile-toplevel :load-toplevel :execute)
7.37+ ,@(loop for i from 0
7.38+ for state in '(parsing-delimiter-dash-start
7.39+ parsing-delimiter-dash
7.40+ parsing-delimiter
7.41+ parsing-delimiter-end
7.42+ parsing-delimiter-almost-done
7.43+ parsing-delimiter-done
7.44+ header-field-start
7.45+ body-start
7.46+ looking-for-delimiter
7.47+ maybe-delimiter-start
7.48+ maybe-delimiter-first-dash
7.49+ maybe-delimiter-second-dash
7.50+ body-almost-done
7.51+ body-done)
7.52+ collect `(defconstant ,(format-symbol t "+~A+" state) ,i)))
7.53+
7.54+(defun http-multipart-parse (parser callbacks data &key (start 0) end)
7.55+ (declare (type simple-byte-vector data))
7.56+ (let* ((end (or end (length data)))
7.57+ (boundary (map '(simple-array (unsigned-byte 8) (*)) #'char-code (ll-multipart-parser-boundary parser)))
7.58+ (boundary-length (length boundary))
7.59+ (header-parser (ll-multipart-parser-header-parser parser)))
7.60+ (declare (type simple-byte-vector boundary))
7.61+ (when (= start end)
7.62+ (return-from http-multipart-parse start))
7.63+
7.64+ (macrolet ((with-body-cb (callback &body body)
7.65+ `(handler-case (when-let ((,callback (callbacks-body callbacks)))
7.66+ ,@body)
7.67+ (error (e)
7.68+ (error 'cb-body :error e))))
7.69+ (call-body-cb (&optional (end '(ll-multipart-parser-boundary-mark parser)))
7.70+ (let ((g-end (gensym "END")))
7.71+ `(with-body-cb callback
7.72+ (when (ll-multipart-parser-body-buffer parser)
7.73+ (funcall callback parser
7.74+ (ll-multipart-parser-body-buffer parser)
7.75+ 0 (length (ll-multipart-parser-body-buffer parser)))
7.76+ (setf (ll-multipart-parser-body-buffer parser) nil))
7.77+ (when-let ((,g-end ,end))
7.78+ (funcall callback parser data
7.79+ (ll-multipart-parser-body-mark parser)
7.80+ ,g-end)))))
7.81+ (flush-boundary-buffer ()
7.82+ `(with-body-cb callback
7.83+ (when (ll-multipart-parser-boundary-buffer parser)
7.84+ (funcall callback parser
7.85+ (ll-multipart-parser-boundary-buffer parser)
7.86+ 0 (length (ll-multipart-parser-boundary-buffer parser)))
7.87+ (setf (ll-multipart-parser-boundary-buffer parser) nil)))))
7.88+ (let* ((p start)
7.89+ (byte (aref data p)))
7.90+ #+fast-http-debug
7.91+ (log:debug (code-char byte))
7.92+ (tagbody
7.93+ (macrolet ((go-state (tag &optional (advance 1))
7.94+ `(progn
7.95+ ,(case advance
7.96+ (0 ())
7.97+ (1 '(incf p))
7.98+ (otherwise `(incf p ,advance)))
7.99+ (setf (ll-multipart-parser-state parser) ,tag)
7.100+ #+fast-http-debug
7.101+ (log:debug ,(princ-to-string tag))
7.102+ ,@(and (not (eql advance 0))
7.103+ `((when (= p end)
7.104+ (go exit-loop))
7.105+ (setq byte (aref data p))
7.106+ #+fast-http-debug
7.107+ (log:debug (code-char byte))))
7.108+ (go ,tag))))
7.109+ (tagcasev (ll-multipart-parser-state parser)
7.110+ (+parsing-delimiter-dash-start+
7.111+ (unless (= byte +dash+)
7.112+ (go-state +header-field-start+ 0))
7.113+ (go-state +parsing-delimiter-dash+))
7.114+
7.115+ (+parsing-delimiter-dash+
7.116+ (unless (= byte +dash+)
7.117+ (error 'invalid-multipart-body))
7.118+ (go-state +parsing-delimiter+))
7.119+
7.120+ (+parsing-delimiter+
7.121+ (let ((end2 (+ p boundary-length)))
7.122+ (cond
7.123+ ((ll-multipart-parser-boundary-buffer parser)
7.124+ (when (< (+ end (length (ll-multipart-parser-boundary-buffer parser)) -3) end2)
7.125+ (setf (ll-multipart-parser-boundary-buffer parser)
7.126+ (concatenate 'simple-byte-vector
7.127+ (ll-multipart-parser-boundary-buffer parser)
7.128+ data))
7.129+ (go exit-loop))
7.130+ (let ((data2 (make-array boundary-length :element-type '(unsigned-byte 8)))
7.131+ (boundary-buffer-length (length (ll-multipart-parser-boundary-buffer parser))))
7.132+ (replace data2 (ll-multipart-parser-boundary-buffer parser)
7.133+ :start2 2)
7.134+ (replace data2 data
7.135+ :start1 (- boundary-buffer-length 2))
7.136+ (unless (search boundary data2)
7.137+ ;; Still in the body
7.138+ (when (ll-multipart-parser-body-mark parser)
7.139+ (call-body-cb nil)
7.140+ (flush-boundary-buffer)
7.141+ (go-state +looking-for-delimiter+))
7.142+ (error 'invalid-boundary))
7.143+ (go-state +parsing-delimiter-end+ (- boundary-length boundary-buffer-length -2))))
7.144+ ((< (1- end) end2)
7.145+ ;; EOF
7.146+ (setf (ll-multipart-parser-boundary-buffer parser)
7.147+ (if (ll-multipart-parser-boundary-buffer parser)
7.148+ (concatenate 'simple-byte-vector
7.149+ (ll-multipart-parser-boundary-buffer parser)
7.150+ (subseq data (max 0 (- p 2))))
7.151+ (subseq data (max 0 (- p 2)))))
7.152+ (go exit-loop))
7.153+ (T
7.154+ (unless (search boundary data :start2 p :end2 end2)
7.155+ ;; Still in the body
7.156+ (when (ll-multipart-parser-body-mark parser)
7.157+ (go-state +looking-for-delimiter+))
7.158+ (error 'invalid-boundary))
7.159+ (go-state +parsing-delimiter-end+ boundary-length)))))
7.160+
7.161+ (+parsing-delimiter-end+
7.162+ (casev byte
7.163+ (+cr+ (go-state +parsing-delimiter-almost-done+))
7.164+ (+lf+ (go-state +parsing-delimiter-almost-done+ 0))
7.165+ (+dash+ (go-state +body-almost-done+))
7.166+ (otherwise
7.167+ ;; Still in the body
7.168+ (when (ll-multipart-parser-body-mark parser)
7.169+ (call-body-cb nil)
7.170+ (flush-boundary-buffer)
7.171+ (go-state +looking-for-delimiter+))
7.172+ (error 'invalid-boundary))))
7.173+
7.174+ (+parsing-delimiter-almost-done+
7.175+ (unless (= byte +lf+)
7.176+ (error 'invalid-boundary))
7.177+ (when (ll-multipart-parser-body-mark parser)
7.178+ ;; got a part
7.179+ (when (ll-multipart-parser-boundary-mark parser)
7.180+ (call-body-cb))
7.181+ (when-let ((callback (callbacks-message-complete callbacks)))
7.182+ (handler-case (funcall callback parser)
7.183+ (error (e)
7.184+ (error 'cb-message-complete :error e)))))
7.185+ (go-state +parsing-delimiter-done+))
7.186+
7.187+ (+parsing-delimiter-done+
7.188+ (when-let ((callback (callbacks-message-begin callbacks)))
7.189+ (handler-case (funcall callback parser)
7.190+ (error (e)
7.191+ (error 'cb-message-begin :error e))))
7.192+ (setf (ll-multipart-parser-body-mark parser) p)
7.193+ (go-state +header-field-start+ 0))
7.194+
7.195+ (+header-field-start+
7.196+ (let ((next (parse-headers header-parser callbacks data p end)))
7.197+ (setq p (1- next)) ;; XXX
7.198+ ;; parsing headers done
7.199+ (when (= (http-state header-parser) +state-body+)
7.200+ (when-let ((callback (callbacks-headers-complete callbacks)))
7.201+ (handler-case (funcall callback parser)
7.202+ (error (e)
7.203+ (error 'cb-headers-complete :error e))))
7.204+ (setf (http-state header-parser) +state-headers+))
7.205+ (go-state +body-start+ 0)))
7.206+
7.207+ (+body-start+
7.208+ (setf (ll-multipart-parser-body-mark parser) (1+ p))
7.209+ (go-state +looking-for-delimiter+))
7.210+
7.211+ (+looking-for-delimiter+
7.212+ (setf (ll-multipart-parser-boundary-mark parser) nil)
7.213+ (casev byte
7.214+ (+cr+ (setf (ll-multipart-parser-boundary-mark parser) p)
7.215+ (go-state +maybe-delimiter-start+))
7.216+ (otherwise (go-state +looking-for-delimiter+))))
7.217+
7.218+ (+maybe-delimiter-start+
7.219+ (unless (= byte +lf+)
7.220+ (go-state +looking-for-delimiter+ 0))
7.221+ (go-state +maybe-delimiter-first-dash+))
7.222+
7.223+ (+maybe-delimiter-first-dash+
7.224+ (if (= byte +dash+)
7.225+ (go-state +maybe-delimiter-second-dash+)
7.226+ (if (= byte +cr+)
7.227+ (progn
7.228+ (setf (ll-multipart-parser-boundary-mark parser) p)
7.229+ (go-state +maybe-delimiter-start+))
7.230+ (go-state +looking-for-delimiter+))))
7.231+
7.232+ (+maybe-delimiter-second-dash+
7.233+ (if (= byte +dash+)
7.234+ (go-state +parsing-delimiter+)
7.235+ (go-state +looking-for-delimiter+)))
7.236+
7.237+ (+body-almost-done+
7.238+ (casev byte
7.239+ (+dash+ (go-state +body-done+ 0))
7.240+ (otherwise (error 'invalid-multipart-body))))
7.241+
7.242+ (+body-done+
7.243+ (when (ll-multipart-parser-body-mark parser)
7.244+ ;; got a part
7.245+ (setf (ll-multipart-parser-body-buffer parser) nil)
7.246+ (call-body-cb)
7.247+ (when-let ((callback (callbacks-message-complete callbacks)))
7.248+ (handler-case (funcall callback parser)
7.249+ (error (e)
7.250+ (error 'cb-message-complete :error e))))
7.251+ (setf (ll-multipart-parser-body-mark parser) nil))
7.252+ (go exit-loop))))
7.253+ exit-loop)
7.254+ (when (ll-multipart-parser-body-mark parser)
7.255+ (when (<= +looking-for-delimiter+
7.256+ (ll-multipart-parser-state parser)
7.257+ +maybe-delimiter-second-dash+)
7.258+ (call-body-cb (or (ll-multipart-parser-boundary-mark parser) p)))
7.259+ ;; buffer the last part
7.260+ (when (ll-multipart-parser-boundary-mark parser)
7.261+ (setf (ll-multipart-parser-body-buffer parser)
7.262+ (if (ll-multipart-parser-body-buffer parser)
7.263+ (concatenate 'simple-byte-vector
7.264+ (ll-multipart-parser-body-buffer parser)
7.265+ (subseq data (ll-multipart-parser-boundary-mark parser)))
7.266+ (subseq data (ll-multipart-parser-boundary-mark parser)))))
7.267+
7.268+ (setf (ll-multipart-parser-body-mark parser) 0
7.269+ (ll-multipart-parser-boundary-mark parser) nil))
7.270+ p))))
7.271+
7.272 (defun make-multipart-parser (content-type callback)
7.273 (check-type content-type string)
7.274 (let ((boundary (find-boundary content-type)))
7.275@@ -726,7 +976,7 @@
7.276 `(when-let ((,callback (,(format-symbol t "~A-~A" :callbacks name) ,callbacks)))
7.277 (handler-bind ((error
7.278 (lambda (,e)
7.279- (unless (typep ,e 'fast-http-error)
7.280+ (unless (typep ,e 'http-error)
7.281 (error ',(format-symbol t "~A-~A" :cb name)
7.282 :error ,e)
7.283 (abort ,e)))))
7.284@@ -737,7 +987,7 @@
7.285 `(when-let ((,callback (,(format-symbol t "~A-~A" :callbacks name) ,callbacks)))
7.286 (handler-bind ((error
7.287 (lambda (,e)
7.288- (unless (typep ,e 'fast-http-error)
7.289+ (unless (typep ,e 'http-error)
7.290 (error ',(format-symbol t "~A-~A" :cb name)
7.291 :error ,e)
7.292 (abort ,e)))))
7.293@@ -750,7 +1000,7 @@
7.294 (define-condition eof () ())
7.295
7.296 (define-condition expect-failed (parsing-error)
7.297- ((fast-http.error::description :initform "expect failed")))
7.298+ ((description :initform "expect failed")))
7.299
7.300
7.301 ;;
7.302@@ -1583,254 +1833,3 @@
7.303 (funcall (the function header-parameter-value-callback)
7.304 data parameter-value-mark p))))))
7.305 p))
7.306-
7.307-;;; multipart-parser
7.308-(defstruct (ll-multipart-parser (:constructor make-ll-multipart-parser
7.309- (&key boundary
7.310- &aux (header-parser
7.311- (let ((parser (make-http)))
7.312- (setf (http-state parser) +state-headers+)
7.313- parser)))))
7.314- (state 0 :type fixnum)
7.315- (header-parser)
7.316- boundary
7.317- body-mark
7.318- body-buffer
7.319- boundary-mark
7.320- boundary-buffer)
7.321-
7.322-#.`(eval-when (:compile-toplevel :load-toplevel :execute)
7.323- ,@(loop for i from 0
7.324- for state in '(parsing-delimiter-dash-start
7.325- parsing-delimiter-dash
7.326- parsing-delimiter
7.327- parsing-delimiter-end
7.328- parsing-delimiter-almost-done
7.329- parsing-delimiter-done
7.330- header-field-start
7.331- body-start
7.332- looking-for-delimiter
7.333- maybe-delimiter-start
7.334- maybe-delimiter-first-dash
7.335- maybe-delimiter-second-dash
7.336- body-almost-done
7.337- body-done)
7.338- collect `(defconstant ,(format-symbol t "+~A+" state) ,i)))
7.339-
7.340-(defun http-multipart-parse (parser callbacks data &key (start 0) end)
7.341- (declare (type simple-byte-vector data))
7.342- (let* ((end (or end (length data)))
7.343- (boundary (map '(simple-array (unsigned-byte 8) (*)) #'char-code (ll-multipart-parser-boundary parser)))
7.344- (boundary-length (length boundary))
7.345- (header-parser (ll-multipart-parser-header-parser parser)))
7.346- (declare (type simple-byte-vector boundary))
7.347- (when (= start end)
7.348- (return-from http-multipart-parse start))
7.349-
7.350- (macrolet ((with-body-cb (callback &body body)
7.351- `(handler-case (when-let ((,callback (callbacks-body callbacks)))
7.352- ,@body)
7.353- (error (e)
7.354- (error 'cb-body :error e))))
7.355- (call-body-cb (&optional (end '(ll-multipart-parser-boundary-mark parser)))
7.356- (let ((g-end (gensym "END")))
7.357- `(with-body-cb callback
7.358- (when (ll-multipart-parser-body-buffer parser)
7.359- (funcall callback parser
7.360- (ll-multipart-parser-body-buffer parser)
7.361- 0 (length (ll-multipart-parser-body-buffer parser)))
7.362- (setf (ll-multipart-parser-body-buffer parser) nil))
7.363- (when-let ((,g-end ,end))
7.364- (funcall callback parser data
7.365- (ll-multipart-parser-body-mark parser)
7.366- ,g-end)))))
7.367- (flush-boundary-buffer ()
7.368- `(with-body-cb callback
7.369- (when (ll-multipart-parser-boundary-buffer parser)
7.370- (funcall callback parser
7.371- (ll-multipart-parser-boundary-buffer parser)
7.372- 0 (length (ll-multipart-parser-boundary-buffer parser)))
7.373- (setf (ll-multipart-parser-boundary-buffer parser) nil)))))
7.374- (let* ((p start)
7.375- (byte (aref data p)))
7.376- #+fast-http-debug
7.377- (log:debug (code-char byte))
7.378- (tagbody
7.379- (macrolet ((go-state (tag &optional (advance 1))
7.380- `(progn
7.381- ,(case advance
7.382- (0 ())
7.383- (1 '(incf p))
7.384- (otherwise `(incf p ,advance)))
7.385- (setf (ll-multipart-parser-state parser) ,tag)
7.386- #+fast-http-debug
7.387- (log:debug ,(princ-to-string tag))
7.388- ,@(and (not (eql advance 0))
7.389- `((when (= p end)
7.390- (go exit-loop))
7.391- (setq byte (aref data p))
7.392- #+fast-http-debug
7.393- (log:debug (code-char byte))))
7.394- (go ,tag))))
7.395- (tagcasev (ll-multipart-parser-state parser)
7.396- (+parsing-delimiter-dash-start+
7.397- (unless (= byte +dash+)
7.398- (go-state +header-field-start+ 0))
7.399- (go-state +parsing-delimiter-dash+))
7.400-
7.401- (+parsing-delimiter-dash+
7.402- (unless (= byte +dash+)
7.403- (error 'invalid-multipart-body))
7.404- (go-state +parsing-delimiter+))
7.405-
7.406- (+parsing-delimiter+
7.407- (let ((end2 (+ p boundary-length)))
7.408- (cond
7.409- ((ll-multipart-parser-boundary-buffer parser)
7.410- (when (< (+ end (length (ll-multipart-parser-boundary-buffer parser)) -3) end2)
7.411- (setf (ll-multipart-parser-boundary-buffer parser)
7.412- (concatenate 'simple-byte-vector
7.413- (ll-multipart-parser-boundary-buffer parser)
7.414- data))
7.415- (go exit-loop))
7.416- (let ((data2 (make-array boundary-length :element-type '(unsigned-byte 8)))
7.417- (boundary-buffer-length (length (ll-multipart-parser-boundary-buffer parser))))
7.418- (replace data2 (ll-multipart-parser-boundary-buffer parser)
7.419- :start2 2)
7.420- (replace data2 data
7.421- :start1 (- boundary-buffer-length 2))
7.422- (unless (search boundary data2)
7.423- ;; Still in the body
7.424- (when (ll-multipart-parser-body-mark parser)
7.425- (call-body-cb nil)
7.426- (flush-boundary-buffer)
7.427- (go-state +looking-for-delimiter+))
7.428- (error 'invalid-boundary))
7.429- (go-state +parsing-delimiter-end+ (- boundary-length boundary-buffer-length -2))))
7.430- ((< (1- end) end2)
7.431- ;; EOF
7.432- (setf (ll-multipart-parser-boundary-buffer parser)
7.433- (if (ll-multipart-parser-boundary-buffer parser)
7.434- (concatenate 'simple-byte-vector
7.435- (ll-multipart-parser-boundary-buffer parser)
7.436- (subseq data (max 0 (- p 2))))
7.437- (subseq data (max 0 (- p 2)))))
7.438- (go exit-loop))
7.439- (T
7.440- (unless (search boundary data :start2 p :end2 end2)
7.441- ;; Still in the body
7.442- (when (ll-multipart-parser-body-mark parser)
7.443- (go-state +looking-for-delimiter+))
7.444- (error 'invalid-boundary))
7.445- (go-state +parsing-delimiter-end+ boundary-length)))))
7.446-
7.447- (+parsing-delimiter-end+
7.448- (casev byte
7.449- (+cr+ (go-state +parsing-delimiter-almost-done+))
7.450- (+lf+ (go-state +parsing-delimiter-almost-done+ 0))
7.451- (+dash+ (go-state +body-almost-done+))
7.452- (otherwise
7.453- ;; Still in the body
7.454- (when (ll-multipart-parser-body-mark parser)
7.455- (call-body-cb nil)
7.456- (flush-boundary-buffer)
7.457- (go-state +looking-for-delimiter+))
7.458- (error 'invalid-boundary))))
7.459-
7.460- (+parsing-delimiter-almost-done+
7.461- (unless (= byte +lf+)
7.462- (error 'invalid-boundary))
7.463- (when (ll-multipart-parser-body-mark parser)
7.464- ;; got a part
7.465- (when (ll-multipart-parser-boundary-mark parser)
7.466- (call-body-cb))
7.467- (when-let ((callback (callbacks-message-complete callbacks)))
7.468- (handler-case (funcall callback parser)
7.469- (error (e)
7.470- (error 'cb-message-complete :error e)))))
7.471- (go-state +parsing-delimiter-done+))
7.472-
7.473- (+parsing-delimiter-done+
7.474- (when-let ((callback (callbacks-message-begin callbacks)))
7.475- (handler-case (funcall callback parser)
7.476- (error (e)
7.477- (error 'cb-message-begin :error e))))
7.478- (setf (ll-multipart-parser-body-mark parser) p)
7.479- (go-state +header-field-start+ 0))
7.480-
7.481- (+header-field-start+
7.482- (let ((next (parse-headers header-parser callbacks data p end)))
7.483- (setq p (1- next)) ;; XXX
7.484- ;; parsing headers done
7.485- (when (= (http-state header-parser) +state-body+)
7.486- (when-let ((callback (callbacks-headers-complete callbacks)))
7.487- (handler-case (funcall callback parser)
7.488- (error (e)
7.489- (error 'cb-headers-complete :error e))))
7.490- (setf (http-state header-parser) +state-headers+))
7.491- (go-state +body-start+ 0)))
7.492-
7.493- (+body-start+
7.494- (setf (ll-multipart-parser-body-mark parser) (1+ p))
7.495- (go-state +looking-for-delimiter+))
7.496-
7.497- (+looking-for-delimiter+
7.498- (setf (ll-multipart-parser-boundary-mark parser) nil)
7.499- (casev byte
7.500- (+cr+ (setf (ll-multipart-parser-boundary-mark parser) p)
7.501- (go-state +maybe-delimiter-start+))
7.502- (otherwise (go-state +looking-for-delimiter+))))
7.503-
7.504- (+maybe-delimiter-start+
7.505- (unless (= byte +lf+)
7.506- (go-state +looking-for-delimiter+ 0))
7.507- (go-state +maybe-delimiter-first-dash+))
7.508-
7.509- (+maybe-delimiter-first-dash+
7.510- (if (= byte +dash+)
7.511- (go-state +maybe-delimiter-second-dash+)
7.512- (if (= byte +cr+)
7.513- (progn
7.514- (setf (ll-multipart-parser-boundary-mark parser) p)
7.515- (go-state +maybe-delimiter-start+))
7.516- (go-state +looking-for-delimiter+))))
7.517-
7.518- (+maybe-delimiter-second-dash+
7.519- (if (= byte +dash+)
7.520- (go-state +parsing-delimiter+)
7.521- (go-state +looking-for-delimiter+)))
7.522-
7.523- (+body-almost-done+
7.524- (casev byte
7.525- (+dash+ (go-state +body-done+ 0))
7.526- (otherwise (error 'invalid-multipart-body))))
7.527-
7.528- (+body-done+
7.529- (when (ll-multipart-parser-body-mark parser)
7.530- ;; got a part
7.531- (setf (ll-multipart-parser-body-buffer parser) nil)
7.532- (call-body-cb)
7.533- (when-let ((callback (callbacks-message-complete callbacks)))
7.534- (handler-case (funcall callback parser)
7.535- (error (e)
7.536- (error 'cb-message-complete :error e))))
7.537- (setf (ll-multipart-parser-body-mark parser) nil))
7.538- (go exit-loop))))
7.539- exit-loop)
7.540- (when (ll-multipart-parser-body-mark parser)
7.541- (when (<= +looking-for-delimiter+
7.542- (ll-multipart-parser-state parser)
7.543- +maybe-delimiter-second-dash+)
7.544- (call-body-cb (or (ll-multipart-parser-boundary-mark parser) p)))
7.545- ;; buffer the last part
7.546- (when (ll-multipart-parser-boundary-mark parser)
7.547- (setf (ll-multipart-parser-body-buffer parser)
7.548- (if (ll-multipart-parser-body-buffer parser)
7.549- (concatenate 'simple-byte-vector
7.550- (ll-multipart-parser-body-buffer parser)
7.551- (subseq data (ll-multipart-parser-boundary-mark parser)))
7.552- (subseq data (ll-multipart-parser-boundary-mark parser)))))
7.553-
7.554- (setf (ll-multipart-parser-body-mark parser) 0
7.555- (ll-multipart-parser-boundary-mark parser) nil))
7.556- p))))
8.1--- a/lisp/lib/net/util.lisp Tue May 21 17:13:34 2024 -0400
8.2+++ b/lisp/lib/net/util.lisp Tue May 21 22:20:29 2024 -0400
8.3@@ -4,6 +4,7 @@
8.4
8.5 ;; from usocket
8.6 (defun get-address-by-name (name)
8.7+ "Return the address of a host by NAME."
8.8 (multiple-value-bind (host4 host6)
8.9 (get-host-by-name name)
8.10 (let ((addr4 (when host4
8.11@@ -14,7 +15,7 @@
8.12
8.13 ;; from https://github.com/eudoxia0/find-port
8.14 (defun port-open-p (port &key (host *localhost*))
8.15- "Determine if the port is open."
8.16+ "Determine if a PORT is open on the given HOST."
8.17 (handler-case
8.18 (let ((socket (make-instance 'inet-socket :type :stream)))
8.19 (setf (sockopt-reuse-address socket) t)
9.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2+++ b/lisp/lib/parse/bytes.lisp Tue May 21 22:20:29 2024 -0400
9.3@@ -0,0 +1,482 @@
9.4+;;; parse/bytes.lisp --- Procedural Parser
9.5+
9.6+;; swiped from Fukamachi's proc-parser.lisp. Will re-implement at a later
9.7+;; date.
9.8+
9.9+;;; License:
9.10+;; Copyright 2015 Eitaro Fukamachi
9.11+
9.12+;; Redistribution and use in source and binary forms, with or without
9.13+;; modification, are permitted provided that the following conditions are met:
9.14+
9.15+;; 1. Redistributions of source code must retain the above copyright notice,
9.16+;; this list of conditions and the following disclaimer.
9.17+
9.18+;; 2. Redistributions in binary form must reproduce the above copyright
9.19+;; notice, this list of conditions and the following disclaimer in the
9.20+;; documentation and/or other materials provided with the distribution.
9.21+
9.22+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
9.23+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
9.24+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
9.25+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
9.26+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
9.27+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
9.28+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
9.29+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
9.30+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
9.31+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
9.32+;; POSSIBILITY OF SUCH DAMAGE.
9.33+
9.34+;;; Code:
9.35+(in-package :parse/bytes)
9.36+
9.37+(define-condition match-failed (error)
9.38+ ((elem :initarg :elem
9.39+ :initform nil)
9.40+ (expected :initarg :expected
9.41+ :initform nil))
9.42+ (:report (lambda (condition stream)
9.43+ (with-slots (elem expected) condition
9.44+ (format stream
9.45+ "Match failed~:[~;~:*: ~S~]~:[~;~:* (expected: ~{~S~^, ~})~]"
9.46+ (ensure-char-elem elem) expected)))))
9.47+
9.48+(defun convert-case-conditions (var chars)
9.49+ (cond
9.50+ ((consp chars)
9.51+ `(or ,@(loop for ch in chars
9.52+ if (characterp ch)
9.53+ collect `(char= ,var ,ch)
9.54+ else
9.55+ collect `(= ,var ,ch))))
9.56+ ((eq chars 'otherwise)
9.57+ t)
9.58+ (t (if (characterp chars)
9.59+ `(char= ,var ,chars)
9.60+ `(= ,var ,chars)))))
9.61+
9.62+(defun typed-case-tagbodies (var &rest cases)
9.63+ (cond
9.64+ ((null cases) nil)
9.65+ ((= 1 (length cases))
9.66+ `((when ,(convert-case-conditions var (car (first cases)))
9.67+ ,@(cdr (first cases)))))
9.68+ ((and (= 2 (length cases))
9.69+ (eq (car (second cases)) 'otherwise))
9.70+ `((unless ,(convert-case-conditions var (car (first cases)))
9.71+ ,@(cdr (second cases)))
9.72+ ,@(cdr (first cases))))
9.73+ (t
9.74+ (let ((tags (make-array (length cases) :initial-contents (loop repeat (length cases)
9.75+ collect (gensym))))
9.76+ (end (gensym "END")))
9.77+ `(,@(loop for (chars . body) in cases
9.78+ for i from 0
9.79+ collect `(when ,(convert-case-conditions var chars)
9.80+ (go ,(aref tags i))))
9.81+ ,@(loop for case in cases
9.82+ for i from 0
9.83+ append `(,(aref tags i)
9.84+ ,@(cdr case)
9.85+ (go ,end)))
9.86+ ,end)))))
9.87+
9.88+(defmacro vector-case (elem-var vec-and-options &body cases)
9.89+ (destructuring-bind (vec &key case-insensitive)
9.90+ (ensure-cons vec-and-options)
9.91+ (with-gensyms (otherwise end-tag vector-case-block)
9.92+ (labels ((case-candidates (el)
9.93+ (cond
9.94+ ((not case-insensitive) el)
9.95+ ((characterp el)
9.96+ (cond
9.97+ ((char<= #\a el #\z)
9.98+ `(,el
9.99+ ,(code-char
9.100+ (- (char-code el)
9.101+ #.(- (char-code #\a) (char-code #\A))))))
9.102+ ((char<= #\A el #\Z)
9.103+ `(,el
9.104+ ,(code-char
9.105+ (+ (char-code el)
9.106+ #.(- (char-code #\a) (char-code #\A))))))
9.107+ (t el)))
9.108+ ((typep el '(unsigned-byte 8))
9.109+ (cond
9.110+ ((<= #.(char-code #\a) el #.(char-code #\z))
9.111+ `(,el
9.112+ ,(- el #.(- (char-code #\a) (char-code #\A)))))
9.113+ ((<= #.(char-code #\A) el #.(char-code #\Z))
9.114+ `(,el
9.115+ ,(+ el #.(- (char-code #\a) (char-code #\A)))))
9.116+ (t el)))
9.117+ (t el)))
9.118+ (build-case (i cases vec)
9.119+ (when cases
9.120+ (let ((map (make-hash-table)))
9.121+ (map nil
9.122+ (lambda (case)
9.123+ (unless (vectorp (car case))
9.124+ (error "The first element of cases must be a constant vector"))
9.125+ (unless (<= (length (car case)) i)
9.126+ (push case (gethash (aref (car case) i) map))))
9.127+ cases)
9.128+ (let (res-cases)
9.129+ (maphash (lambda (el cases)
9.130+ (let ((next-case (build-case (1+ i) cases vec)))
9.131+ (cond
9.132+ (next-case
9.133+ (push
9.134+ `(,(case-candidates el)
9.135+ (unless (advance*)
9.136+ ,(if (= (length (caar cases)) (1+ i))
9.137+ `(progn ,@(cdr (car cases))
9.138+ (go ,end-tag))
9.139+ `(go :eof)))
9.140+ ,@(apply #'typed-case-tagbodies elem-var
9.141+ (append
9.142+ next-case
9.143+ `((otherwise (go ,otherwise))))))
9.144+ res-cases))
9.145+ (t
9.146+ (push `(,(case-candidates el)
9.147+ (advance*)
9.148+ (return-from ,vector-case-block
9.149+ (progn ,@(cdr (car cases)))))
9.150+ res-cases)))))
9.151+ map)
9.152+ res-cases)))))
9.153+ (let ((otherwise-case nil))
9.154+ (when (eq (caar (last cases)) 'otherwise)
9.155+ (setq otherwise-case (car (last cases))
9.156+ cases (butlast cases)))
9.157+ `(block ,vector-case-block
9.158+ (tagbody
9.159+ ,@(apply #'typed-case-tagbodies elem-var
9.160+ (append
9.161+ (build-case 0 cases vec)
9.162+ `((otherwise (go ,otherwise)))))
9.163+ (go ,end-tag)
9.164+ ,otherwise
9.165+ ,@(when otherwise-case
9.166+ `(unless (eofp)
9.167+ (return-from ,vector-case-block
9.168+ (progn ,@(cdr otherwise-case)))))
9.169+ ,end-tag)))))))
9.170+
9.171+(defun variable-type (var &optional env)
9.172+ (declare (ignorable env))
9.173+ (cond
9.174+ ((constantp var) (type-of var))
9.175+ #+(or sbcl openmcl cmu allegro)
9.176+ ((and (symbolp var)
9.177+ #+allegro (cadr (assoc 'type (nth-value 2 (variable-information var env))))
9.178+ #-allegro (cdr (assoc 'type (nth-value 2 (variable-information var env))))))
9.179+ ((and (listp var)
9.180+ (eq (car var) 'the)
9.181+ (cadr var)))))
9.182+
9.183+(deftype octets (&optional (len '*))
9.184+ `(simple-array (unsigned-byte 8) (,len)))
9.185+
9.186+(defun variable-type* (var &optional env)
9.187+ (let ((type (variable-type var env)))
9.188+ (cond
9.189+ ((null type) nil)
9.190+ ((subtypep type 'string) 'string)
9.191+ ((subtypep type 'octets) 'octets))))
9.192+
9.193+(defun check-skip-elems (elems)
9.194+ (or (every (lambda (elem)
9.195+ (or (characterp elem)
9.196+ (and (consp elem)
9.197+ (null (cddr elem))
9.198+ (eq (first elem) 'not)
9.199+ (characterp (second elem)))))
9.200+ elems)
9.201+ (error "'skip' takes only constant characters, or a cons starts with 'not'.")))
9.202+
9.203+(defun check-match-cases (cases)
9.204+ (or (every (lambda (case)
9.205+ (and (consp case)
9.206+ (or (eq (car case) 'otherwise)
9.207+ (stringp (car case)))))
9.208+ cases)
9.209+ (error "'match-case' takes only constant strings at the car position.~% ~S" cases)))
9.210+
9.211+
9.212+(defmacro bind ((symb &body bind-forms) &body body)
9.213+ (declare (ignore symb bind-forms body)))
9.214+
9.215+(defmacro subseq* (data start &optional end)
9.216+ `(subseq ,data ,start ,end))
9.217+(defmacro get-elem (form) form)
9.218+(defun ensure-char-elem (elem)
9.219+ (if (characterp elem)
9.220+ elem
9.221+ (code-char elem)))
9.222+
9.223+(defmacro tagbody-with-match-failed (elem &body body)
9.224+ (with-gensyms (block)
9.225+ `(block ,block
9.226+ (tagbody
9.227+ (return-from ,block ,@body)
9.228+ :match-failed
9.229+ (error 'match-failed :elem ,elem)))))
9.230+
9.231+(defmacro parsing-macrolet ((elem data p end)
9.232+ (&rest macros) &body body)
9.233+ `(macrolet ((advance (&optional (step 1))
9.234+ `(or (advance* ,step)
9.235+ (go :eof)))
9.236+ (advance* (&optional (step 1))
9.237+ `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)))
9.238+ (incf ,',p ,step)
9.239+ ,@(if (eql step 0)
9.240+ ()
9.241+ `((if (<= ,',end ,',p)
9.242+ nil
9.243+ (progn
9.244+ (setq ,',elem
9.245+ (aref ,',data ,',p))
9.246+ t))))))
9.247+ (advance-to (to)
9.248+ `(or (advance-to* ,to)
9.249+ (go :eof)))
9.250+ (advance-to* (to)
9.251+ (once-only (to)
9.252+ `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)))
9.253+ (check-type ,to fixnum)
9.254+ (setq ,',p ,to)
9.255+ (if (<= ,',end ,',p)
9.256+ nil
9.257+ (progn
9.258+ (setq ,',elem
9.259+ (aref ,',data ,',p))
9.260+ t)))))
9.261+ (skip (&rest elems)
9.262+ (check-skip-elems elems)
9.263+ `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)))
9.264+ (if (skip-conditions ,',elem ,elems)
9.265+ (advance)
9.266+ (error 'match-failed
9.267+ :elem ,',elem
9.268+ :expected ',elems))))
9.269+ (skip* (&rest elems)
9.270+ (check-skip-elems elems)
9.271+ `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)))
9.272+ (unless (eofp)
9.273+ (loop
9.274+ (unless (skip-conditions ,',elem ,elems)
9.275+ (return))
9.276+ (or (advance*) (go :eof))))))
9.277+ (skip+ (&rest elems)
9.278+ `(progn
9.279+ (skip ,@elems)
9.280+ (skip* ,@elems)))
9.281+ (skip? (&rest elems)
9.282+ (check-skip-elems elems)
9.283+ `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)))
9.284+ (when (skip-conditions ,',elem ,elems)
9.285+ (or (advance*) (go :eof)))))
9.286+ (skip-until (fn)
9.287+ `(loop until ,(if (symbolp fn)
9.288+ `(,fn (get-elem ,',elem))
9.289+ `(funcall ,fn (get-elem ,',elem)))
9.290+ do (or (advance*) (go :eof))))
9.291+ (skip-while (fn)
9.292+ `(loop while ,(if (symbolp fn)
9.293+ `(,fn (get-elem ,',elem))
9.294+ `(funcall ,fn (get-elem ,',elem)))
9.295+ do (or (advance*) (go :eof))))
9.296+ (bind ((symb &body bind-forms) &body body)
9.297+ (with-gensyms (start)
9.298+ `(let ((,start ,',p))
9.299+ (tagbody
9.300+ ,@bind-forms
9.301+ :eof)
9.302+ (prog1
9.303+ (let ((,symb (subseq* ,',data ,start ,',p)))
9.304+ ,@body)
9.305+ (when (eofp)
9.306+ (go :eof))))))
9.307+ (%match (&rest vectors)
9.308+ `(%match-case
9.309+ ,@(loop for vec in vectors
9.310+ collect `(,vec))))
9.311+ (match (&rest vectors)
9.312+ `(block match-block
9.313+ (tagbody
9.314+ (return-from match-block (%match ,@vectors))
9.315+ :match-failed
9.316+ (error 'match-failed :elem ,',elem))))
9.317+ (match? (&rest vectors)
9.318+ (with-gensyms (start start-elem)
9.319+ `(let ((,start ,',p)
9.320+ (,start-elem ,',elem))
9.321+ (block match?-block
9.322+ (tagbody
9.323+ (%match ,@vectors)
9.324+ (return-from match?-block t)
9.325+ :match-failed
9.326+ (setq ,',p ,start
9.327+ ,',elem ,start-elem))))))
9.328+ (match-i (&rest vectors)
9.329+ `(match-i-case
9.330+ ,@(loop for vec in vectors
9.331+ collect `(,vec))))
9.332+ ,@macros)
9.333+ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
9.334+ (labels ((eofp ()
9.335+ (declare (optimize (speed 3) (safety 0) (debug 0)))
9.336+ (<= ,end ,p))
9.337+ (current () (get-elem ,elem))
9.338+ (peek (&key eof-value)
9.339+ (declare (optimize (speed 3) (safety 0) (debug 0)))
9.340+ (let ((len (length ,data)))
9.341+ (declare (type fixnum len))
9.342+ (if (or (eofp) (>= ,p (- ,end 1)) (= ,p (- len 1)))
9.343+ eof-value
9.344+ (aref ,data (+ 1 ,p)))))
9.345+ (pos () (the fixnum ,p)))
9.346+ (declare (inline eofp current pos))
9.347+ ,@body)))
9.348+
9.349+(defmacro with-string-parsing ((data &key start end) &body body)
9.350+ (with-gensyms (g-end elem p body-block)
9.351+ (once-only (data)
9.352+ `(let ((,elem #\Nul)
9.353+ (,p ,(if start
9.354+ `(or ,start 0)
9.355+ 0))
9.356+ (,g-end ,(if end
9.357+ `(or ,end (length ,data))
9.358+ `(length ,data))))
9.359+ (declare (type simple-string ,data)
9.360+ (type fixnum ,p ,g-end)
9.361+ (type character ,elem))
9.362+ (parsing-macrolet (,elem ,data ,p ,g-end)
9.363+ ((skip-conditions (elem-var elems)
9.364+ `(or ,@(loop for el in elems
9.365+ if (and (consp el)
9.366+ (eq (car el) 'not))
9.367+ collect `(not (char= ,(cadr el) ,elem-var))
9.368+ else
9.369+ collect `(char= ,el ,elem-var))))
9.370+ (%match-case (&rest cases)
9.371+ (check-match-cases cases)
9.372+ `(prog1
9.373+ (vector-case ,',elem (,',data)
9.374+ ,@(if (find 'otherwise cases :key #'car :test #'eq)
9.375+ cases
9.376+ (append cases
9.377+ '((otherwise (go :match-failed))))))
9.378+ (when (eofp) (go :eof))))
9.379+ (%match-i-case (&rest cases)
9.380+ (check-match-cases cases)
9.381+ `(prog1
9.382+ (vector-case ,',elem (,',data :case-insensitive t)
9.383+ ,@(if (find 'otherwise cases :key #'car :test #'eq)
9.384+ cases
9.385+ (append cases
9.386+ '((otherwise (go :match-failed))))))
9.387+ (when (eofp) (go :eof))))
9.388+ (match-case
9.389+ (&rest cases)
9.390+ `(tagbody-with-match-failed ,',elem (%match-case ,@cases)))
9.391+ (match-i-case
9.392+ (&rest cases)
9.393+ `(tagbody-with-match-failed ,',elem (%match-i-case ,@cases))))
9.394+ (block ,body-block
9.395+ (tagbody
9.396+ (when (eofp)
9.397+ (go :eof))
9.398+ (setq ,elem (aref ,data ,p))
9.399+ (return-from ,body-block (progn ,@body))
9.400+ :eof)))))))
9.401+
9.402+(defmacro with-octets-parsing ((data &key start end) &body body)
9.403+ (with-gensyms (g-end elem p body-block)
9.404+ (once-only (data)
9.405+ `(let ((,elem 0)
9.406+ (,p ,(if start
9.407+ `(or ,start 0)
9.408+ 0))
9.409+ (,g-end ,(if end
9.410+ `(or ,end (length ,data))
9.411+ `(length ,data))))
9.412+ (declare (type octets ,data)
9.413+ (type fixnum ,p ,g-end)
9.414+ (type (unsigned-byte 8) ,elem))
9.415+ (parsing-macrolet (,elem ,data ,p ,g-end)
9.416+ ((skip-conditions (elem-var elems)
9.417+ `(or ,@(loop for el in elems
9.418+ if (and (consp el)
9.419+ (eq (car el) 'not))
9.420+ collect `(not (= ,(char-code (cadr el)) ,elem-var))
9.421+ else
9.422+ collect `(= ,(char-code el) ,elem-var))))
9.423+ (%match-case (&rest cases)
9.424+ (check-match-cases cases)
9.425+ (setf cases
9.426+ (loop for case in cases
9.427+ if (stringp (car case))
9.428+ collect (cons (babel:string-to-octets (car case))
9.429+ (cdr case))
9.430+ else
9.431+ collect case))
9.432+ `(prog1
9.433+ (vector-case ,',elem (,',data)
9.434+ ,@(if (find 'otherwise cases :key #'car :test #'eq)
9.435+ cases
9.436+ (append cases
9.437+ '((otherwise (go :match-failed))))))
9.438+ (when (eofp) (go :eof))))
9.439+ (%match-i-case (&rest cases)
9.440+ (check-match-cases cases)
9.441+ (setf cases
9.442+ (loop for case in cases
9.443+ if (stringp (car case))
9.444+ collect (cons (babel:string-to-octets (car case))
9.445+ (cdr case))
9.446+ else
9.447+ collect case))
9.448+ `(prog1
9.449+ (vector-case ,',elem (,',data :case-insensitive t)
9.450+ ,@(if (find 'otherwise cases :key #'car :test #'eq)
9.451+ cases
9.452+ (append cases
9.453+ '((otherwise (go :match-failed))))))
9.454+ (when (eofp) (go :eof))))
9.455+ (match-case
9.456+ (&rest cases)
9.457+ `(tagbody-with-match-failed ,',elem (%match-case ,@cases)))
9.458+ (match-i-case
9.459+ (&rest cases)
9.460+ `(tagbody-with-match-failed ,',elem (%match-i-case ,@cases))))
9.461+ (block ,body-block
9.462+ (tagbody
9.463+ (when (eofp)
9.464+ (go :eof))
9.465+ (setq ,elem (aref ,data ,p))
9.466+ (return-from ,body-block (progn ,@body))
9.467+ :match-failed
9.468+ (error 'match-failed :elem ,elem)
9.469+ :eof)))))))
9.470+
9.471+(defmacro with-vector-parsing ((data &key (start 0) end) &body body &environment env)
9.472+ (let ((data-type (variable-type* data env)))
9.473+ (case data-type
9.474+ (string `(with-string-parsing (,data :start ,start :end ,end) ,@body))
9.475+ (octets `(macrolet ((get-elem (form) `(code-char ,form))
9.476+ (subseq* (data start &optional end)
9.477+ `(babel:octets-to-string ,data :start ,start :end ,end)))
9.478+ (with-octets-parsing (,data :start ,start :end ,end) ,@body)))
9.479+ (otherwise (once-only (data)
9.480+ `(etypecase ,data
9.481+ (string (with-string-parsing (,data :start ,start :end ,end) ,@body))
9.482+ (octets (macrolet ((get-elem (form) `(code-char ,form))
9.483+ (subseq* (data start &optional end)
9.484+ `(babel:octets-to-string ,data :start ,start :end ,end)))
9.485+ (with-octets-parsing (,data :start ,start :end ,end) ,@body)))))))))
10.1--- a/lisp/lib/parse/parse.asd Tue May 21 17:13:34 2024 -0400
10.2+++ b/lisp/lib/parse/parse.asd Tue May 21 22:20:29 2024 -0400
10.3@@ -4,6 +4,7 @@
10.4 :bug-tracker "https://lab.rwest.io/ellis/packy/issues"
10.5 :depends-on (:cl-ppcre :std)
10.6 :components ((:file "pkg")
10.7+ (:file "bytes")
10.8 (:file "lex")
10.9 (:file "yacc"))
10.10 :in-order-to ((test-op (test-op :parse/tests))))
11.1--- a/lisp/lib/parse/pkg.lisp Tue May 21 17:13:34 2024 -0400
11.2+++ b/lisp/lib/parse/pkg.lisp Tue May 21 22:20:29 2024 -0400
11.3@@ -34,6 +34,39 @@
11.4 :yacc-runtime-error :yacc-parse-error :yacc-parse-error-terminal
11.5 :yacc-parse-error-value :yacc-parse-error-expected-terminals))
11.6
11.7+(defpackage parse/bytes
11.8+ (:use :cl)
11.9+ (:import-from :sb-cltl2
11.10+ :variable-information)
11.11+ (:import-from :std :with-gensyms :once-only
11.12+ :ensure-cons :ignore-some-conditions)
11.13+ (:export :with-vector-parsing
11.14+ :with-string-parsing
11.15+ :with-octets-parsing
11.16+ :eofp
11.17+ :current
11.18+ :peek
11.19+ :eof-value
11.20+ :pos
11.21+ :advance
11.22+ :advance*
11.23+ :advance-to
11.24+ :advance-to*
11.25+ :skip
11.26+ :skip*
11.27+ :skip+
11.28+ :skip?
11.29+ :skip-until
11.30+ :skip-while
11.31+ :bind
11.32+ :match
11.33+ :match-i
11.34+ :match?
11.35+ :match-case
11.36+ :match-i-case
11.37+ :match-failed))
11.38+
11.39+
11.40 (uiop:define-package :parse
11.41 (:use :cl :std)
11.42- (:use-reexport :parse/lex :parse/yacc))
11.43+ (:use-reexport :parse/lex :parse/yacc :parse/bytes))
12.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2+++ b/lisp/std/macs/collecting.lisp Tue May 21 22:20:29 2024 -0400
12.3@@ -0,0 +1,67 @@
12.4+;;; std/macs/collecting.lisp --- Collecting Macros
12.5+
12.6+;; ported from CL-UTILITIES
12.7+
12.8+;;; Code:
12.9+(in-package :std/macs)
12.10+
12.11+;; This should only be called inside of COLLECTING macros, but we
12.12+;; define it here to provide an informative error message and to make
12.13+;; it easier for SLIME (et al.) to get documentation for the COLLECT
12.14+;; function when it's used in the COLLECTING macro.
12.15+(defun collect (thing)
12.16+ "Collect THING in the context established by the COLLECTING macro"
12.17+ (error "Can't collect ~S outside the context of the COLLECTING macro"
12.18+ thing))
12.19+
12.20+(defmacro collecting (&body body)
12.21+ "Collect things into a list forwards. Within the body of this macro,
12.22+the COLLECT function will collect its argument into the list returned
12.23+by COLLECTING."
12.24+ (with-gensyms (collector tail)
12.25+ `(let (,collector ,tail)
12.26+ (labels ((collect (thing)
12.27+ (if ,collector
12.28+ (setf (cdr ,tail)
12.29+ (setf ,tail (list thing)))
12.30+ (setf ,collector
12.31+ (setf ,tail (list thing))))))
12.32+ ,@body)
12.33+ ,collector)))
12.34+
12.35+(defmacro with-collectors ((&rest collectors) &body body)
12.36+ "Collect some things into lists forwards. The names in COLLECTORS
12.37+are defined as local functions which each collect into a separate
12.38+list. Returns as many values as there are collectors, in the order
12.39+they were given."
12.40+ (%with-collectors-check-collectors collectors)
12.41+ (let ((gensyms-alist (%with-collectors-gensyms-alist collectors)))
12.42+ `(let ,(loop for collector in collectors
12.43+ for tail = (cdr (assoc collector gensyms-alist))
12.44+ nconc (list collector tail))
12.45+ (labels ,(loop for collector in collectors
12.46+ for tail = (cdr (assoc collector gensyms-alist))
12.47+ collect `(,collector (thing)
12.48+ (if ,collector
12.49+ (setf (cdr ,tail)
12.50+ (setf ,tail (list thing)))
12.51+ (setf ,collector
12.52+ (setf ,tail (list thing))))))
12.53+ ,@body)
12.54+ (values ,@collectors))))
12.55+
12.56+(defun %with-collectors-check-collectors (collectors)
12.57+ "Check that all of the COLLECTORS are symbols. If not, raise an error."
12.58+ (let ((bad-collector (find-if-not #'symbolp collectors)))
12.59+ (when bad-collector
12.60+ (error 'type-error
12.61+ :datum bad-collector
12.62+ :expected-type 'symbol))))
12.63+
12.64+(defun %with-collectors-gensyms-alist (collectors)
12.65+ "Return an alist mapping the symbols in COLLECTORS to gensyms"
12.66+ (mapcar #'cons collectors
12.67+ (mapcar (compose #'gensym
12.68+ #'(lambda (x)
12.69+ (format nil "~A-TAIL-" x)))
12.70+ collectors)))
13.1--- a/lisp/std/pkg.lisp Tue May 21 17:13:34 2024 -0400
13.2+++ b/lisp/std/pkg.lisp Tue May 21 22:20:29 2024 -0400
13.3@@ -183,9 +183,23 @@
13.4 :task-pool-oracle :task-pool-jobs :task-pool-stages
13.5 :task-pool-workers :task-pool-results))
13.6
13.7+(defpkg :std/fu
13.8+ (:use :cl)
13.9+ (:import-from :std/sym :make-gensym-list)
13.10+ (:export
13.11+ :ensure-function
13.12+ :ensure-functionf
13.13+ :disjoin
13.14+ :conjoin
13.15+ :compose
13.16+ :multiple-value-compose
13.17+ :curry
13.18+ :rcurry))
13.19+
13.20 (defpkg :std/macs
13.21 (:use :cl)
13.22 (:import-from :std/sym :symb :mkstr :make-gensym-list :once-only :with-gensyms)
13.23+ (:import-from :std/fu :compose)
13.24 (:import-from :std/named-readtables :in-readtable :parse-body)
13.25 (:import-from :std/list :flatten :defmacro!)
13.26 (:export
13.27@@ -246,20 +260,9 @@
13.28 :pandoric-hotpatch
13.29 :pandoric-recode
13.30 :plambda
13.31- :pandoric-eval))
13.32-
13.33-(defpkg :std/fu
13.34- (:use :cl)
13.35- (:import-from :std/macs :make-gensym-list)
13.36- (:export
13.37- :ensure-function
13.38- :ensure-functionf
13.39- :disjoin
13.40- :conjoin
13.41- :compose
13.42- :multiple-value-compose
13.43- :curry
13.44- :rcurry))
13.45+ :pandoric-eval
13.46+ :with-collectors
13.47+ :collecting))
13.48
13.49 (defpkg :std/readtable
13.50 (:use :cl)
14.1--- a/lisp/std/std.asd Tue May 21 17:13:34 2024 -0400
14.2+++ b/lisp/std/std.asd Tue May 21 22:20:29 2024 -0400
14.3@@ -36,7 +36,8 @@
14.4 :components
14.5 ((:file "ana")
14.6 (:file "pan")
14.7- (:file "const")))
14.8+ (:file "const")
14.9+ (:file "collecting")))
14.10 (:file "bit")
14.11 (:file "fmt")
14.12 (:file "path")
