@@ -3,3 +3,6 @@

 gen-patmatch.fasl

 timer.fasl

 *.fasl

+*~

+.*fasl

+*.*fasl

new file mode 100644

@@ -0,0 +1,30 @@

+;;; How to make the popcnt instruction available

+(defpackage "POPCNT"

+  (:use "CL")

+  (:export "POPCNT"))

+

+(in-package "POPCNT")

+

+(sb-c:defknown popcnt ((unsigned-byte 64)) (integer 0 64)

+    (sb-c:foldable sb-c:flushable sb-c:movable)

+  :overwrite-fndb-silently t)

+

+(in-package "SB-VM")

+

+(define-vop (popcnt:popcnt)

+  (:policy :fast-safe)

+  (:translate popcnt:popcnt)

+  (:args (x :scs (unsigned-reg) :target r))

+  (:arg-types unsigned-num)

+  (:results (r :scs (unsigned-reg)))

+  (:result-types unsigned-num)

+  (:generator 3

+    (unless (location= r x) ; only break the spurious dep. chain

+      (inst xor r r))       ; if r isn't the same register as x.

+    (inst popcnt r x)))

+

+(in-package "POPCNT")

+

+(defun popcnt (x)

+  (declare (inline))

+  (popcnt x))

new file mode 100644

@@ -0,0 +1,69 @@

+(defpackage :bintree

+  (:use :cl )

+  (:export ))

+(in-package :bintree)

+

+(defclass bintree ()

+  ((value :initarg :value :accessor node-value)

+   (%left :initarg :left :accessor tree-left :initform nil)

+   (%right :initarg :right :accessor tree-right :initform nil)))

+

+(define-condition constraint-violated (serious-condition)

+  ())

+

+(defmethod (setf tree-left) :before ((new-value bintree) (object bintree))

+  (unless (<= (node-value new-value)

+              (node-value object))

+    (error 'constraint-violated)))

+

+(defmethod (setf tree-left) ((new-value integer) (object bintree))

+  (setf (tree-left object) (make-instance 'bintree :value new-value)))

+

+(defmethod (setf tree-right) :before ((new-value bintree) (object bintree))

+  (unless (> (node-value new-value)

+             (node-value object))

+    (error 'constraint-violated)))

+

+(defmethod (setf tree-right) ((new-value integer) (object bintree))

+  (setf (tree-right object) (make-instance 'bintree :value new-value)))

+

+(defun insert (tree value)

+  (if (<= value (node-value tree))

+      (if (null (tree-left tree))

+          (setf (tree-left tree) value)

+          (insert (tree-left tree) value))

+      (if (null (tree-right tree))

+          (setf (tree-right tree) value)

+          (insert (tree-right tree) value))))

+

+(defun rotate (tree direction)

+  (ecase direction

+    (:right (let* ((right-child (tree-right tree))

+                   (left-of-right (tree-left right-child)))

+              (setf (tree-left right-child) tree

+                    (tree-right tree) left-of-right)

+              right-child))

+    (:left (let* ((left-child (tree-left tree))

+                  (right-of-left (tree-right left-child)))

+             (setf (tree-right left-child) tree

+                   (tree-left tree) right-of-left)

+             left-child))))

+

+(defun list->tree (list)

+  (declare (optimize (debug 3)))

+  (destructuring-bind (root . rest) list

+    (let ((result (make-instance 'bintree :value root)))

+      (mapcar (lambda (v) (insert result v))

+              rest)

+      result)))

+

+(defmethod print-object ((object bintree) stream)

+  (labels ((print-node (node stream)

+             (if node

+                 (format stream "~a (~a) (~a)"

+                         (node-value node)

+                         (print-node (tree-left node) nil)

+                         (print-node (tree-right node) nil))

+                 (format stream "~a" node))))

+    (print-unreadable-object (object stream :type t :identity t)

+      (format stream "(~a)" (print-node object nil)))))

new file mode 100644

@@ -0,0 +1,104 @@

+

+(:DARKMATTER

+ ((:ID . "1499699102316") (:NEXT . "1499699077360") (:PREV . "") (:COUNT . 0)

+  (:LANG . "lisp")

+  (:LISP . "(eval-when (:compile-toplevel :load-toplevel :execute)

+  (let ((*standard-output* (make-broadcast-stream)))

+    (push (truename \"~/git_repos/fwoar.lisputils\") asdf:*central-registry*)

+    (ql:quickload '(:alexandria :serapeum :lquery :cells :fwoar.lisputils :drakma :puri))))

+(defpackage :cells-html-scraper

+  (:use :cl :alexandria :serapeum :fw.lu :cells))

+(in-package :cells-html-scraper)")

+  (:MD . "")

+  (:OUTPUT

+   . "<div id=\"result\">#&lt;PACKAGE \"CELLS-HTML-SCRAPER\"&gt;</div>"))

+ ((:ID . "1499699077360") (:NEXT . "1499699569637") (:PREV . "1499699102316")

+  (:COUNT . 0) (:LANG . "lisp")

+  (:LISP . "(lquery:define-lquery-macro progn (nodes &rest args)

+  `(lquery:$

+     (inline ,nodes)

+     ,@args))

+

+(lquery:define-lquery-function hn-score (item)

+  (lquery:$1 (inline item)

+             (next)

+             \".score\"

+             (text)))

+

+(lquery:define-lquery-function hn-age (item)

+  (lquery:$1 (inline item)

+             (next)

+             \".age\"

+             (text)))

+

+(lquery:define-lquery-function hn-comments (item)

+  (lquery:$1 (inline item)

+             (next)

+             \".age\"

+             (lquery-funcs:next)

+             (next)

+             (next)

+             (text)))")

+  (:MD . "") (:OUTPUT . "<div id=\"result\">HN-COMMENTS</div>"))

+ ((:ID . "1499699569637") (:NEXT . "1499699613496") (:PREV . "1499699077360")

+  (:COUNT . 0) (:LANG . "lisp")

+  (:LISP . "(defclass hn-item ()

+  ((%url :initarg :url :reader url)

+   (%title :initarg :title :reader title)

+   (%score :initarg :score :reader score)

+   (%age :initarg :age :reader age)

+   (%comments :initarg :comments :reader comments)))

+

+(defun make-hn-item (url title score age comments)

+  (make-instance 'hn-item

+                 :url (puri:parse-uri url)

+                 :title title

+                 :score (when score (parse-integer score :junk-allowed t))

+                 :age age

+                 :comments (when comments (parse-integer comments :junk-allowed t))))")

+  (:MD . "") (:OUTPUT . "<div id=\"result\">MAKE-HN-ITEM</div>"))

+ ((:ID . "1499699613496") (:NEXT . "1499699601303") (:PREV . "1499699569637")

+  (:COUNT . 0) (:LANG . "lisp")

+  (:LISP . "(defmodel url-getter ()

+  ((%url :initarg :url

+         :accessor url

+         :initform (c-in nil))

+   (%text :initform (c? (if (^url)

+                            (^url)

+                            \"\"))

+          :reader text)))")

+  (:MD . "") (:OUTPUT . "<div id=\"result\">NIL</div>"))

+ ((:ID . "1499699601303") (:NEXT . "1499699627294") (:PREV . "1499699613496")

+  (:COUNT . 0) (:LANG . "lisp")

+  (:LISP . "(defmodel hn-scraper ()

+  ((%html :initarg :html

+          :accessor html

+          :initform (c-in \"\"))

+   (%doc :reader %doc :initform (c? (plump:parse (^html))))

+   (%hnmain :reader %hnmain

+            :initform (c? (lquery:$1

+                            (inline (^%doc))

+                            \"#hnmain\")))

+   (%body :reader %body

+          :initform (c? (lquery:$

+                          (inline (^%hnmain))

+                          \".itemlist tr.athing\")))

+   (%titles :reader titles

+            :initform (c? (lquery:$

+                            (inline (^%body))

+                            (combine (progn \".title .storylink\" (attr \"href\")

+                                            (node))

+                                     (progn \".title .storylink\" (text)

+                                            (node))

+                                     (hn-score)

+                                     (hn-age)

+                                     (hn-comments)))))

+   (%items :reader items :initform (c? (map 'vector

+                                            (op (apply 'make-hn-item _*))

+                                            (^titles))))))")

+  (:MD . "") (:OUTPUT . "<div id=\"result\">NIL</div>"))

+ ((:ID . "1499699627294") (:NEXT . "") (:PREV . "1499699601303") (:COUNT . 0)

+  (:LANG . "lisp")

+  (:LISP . "(defparameter *url-getter* (make-instance 'url-getter))

+(defparameter *parser* (make-instance 'hn-scraper :html (^text *url-getter*)))")

+  (:MD . "") (:OUTPUT . ""))) 

\ No newline at end of file

new file mode 100644

@@ -0,0 +1,94 @@

+(defpackage :cells-html-scraper

+  (:use :cl :alexandria :serapeum :fw.lu :cells))

+

+(in-package :cells-html-scraper)

+

+(lquery:define-lquery-macro progn (nodes &rest args)

+  `(lquery:$

+     (inline ,nodes)

+     ,@args))

+

+(lquery:define-lquery-function hn-score (item)

+  (lquery:$1 (inline item)

+             (next)

+             ".score"

+             (text)))

+

+(lquery:define-lquery-function hn-age (item)

+  (lquery:$1 (inline item)

+             (next)

+             ".age"

+             (text)))

+

+(lquery:define-lquery-function hn-comments (item)

+  (lquery:$1 (inline item)

+             (next)

+             ".age"

+             (lquery-funcs:next)

+             (next)

+             (next)

+             (text)))

+

+(defclass hn-item ()

+  ((%url :initarg :url :reader url)

+   (%title :initarg :title :reader title)

+   (%score :initarg :score :reader score)

+   (%age :initarg :age :reader age)

+   (%comments :initarg :comments :reader comments)))

+

+(defun make-hn-item (url title score age comments)

+  (make-instance 'hn-item

+                 :url (puri:parse-uri url)

+                 :title title

+                 :score (when score (parse-integer score :junk-allowed t))

+                 :age age

+                 :comments (when comments (parse-integer comments :junk-allowed t))))

+

+(defmodel hn-scraped ()

+  ((%html :initarg :html

+          :accessor html

+          :initform (c-in ""))

+   (%doc :reader %doc :initform (c? (plump:parse (^html))))

+   (%hnmain :reader %hnmain

+            :initform (c? (lquery:$1

+                            (inline (^%doc))

+                            "#hnmain")))

+   (%body :reader %body

+          :initform (c? (lquery:$

+                          (inline (^%hnmain))

+                          ".itemlist tr.athing")))

+   (%titles :reader titles

+            :initform (c? (lquery:$

+                            (inline (^%body))

+                            (combine (progn ".title .storylink" (attr "href")

+                                            (node))

+                                     (progn ".title .storylink" (text)

+                                            (node))

+                                     (hn-score)

+                                     (hn-age)

+                                     (hn-comments)))))

+   (%items :reader items :initform (c? (map 'vector

+                                            (op (apply 'make-hn-item _*))

+                                            (^titles))))))

+

+(defmodel url-getter ()

+  ((%url :initarg :url

+         :accessor url

+         :initform (c-in '()))

+   (%text :reader text

+          :initform (c? (let ((drakma:*text-content-types* (acons "application" "json" drakma:*text-content-types*)))

+                          (drakma:http-request (^url)))))))

+

+(defun get-links (url)

+  (restart-case (values (map 'list (compose (op (list* url _))

+                                            #'cdr)

+                             (remove-if-not (op (string= _ "alternate"))

+                                            (lquery:$

+                                              (initialize (drakma:http-request url))

+                                              "link"

+                                              (combine (attr "rel") (attr "href") (attr "type")))

+                                            :key #'car))

+                        "")

+    (continue nil

+      :report (lambda (stream) (format stream "skip url ~a" url))

+      (values nil url))))

new file mode 100644

@@ -0,0 +1,28 @@

+(defpackage :changelog-filter

+  (:use :cl :alexandria :serapeum :fw.lu)

+  (:export ))

+(in-package :changelog-filter)

+

+(defparameter *changelog-path* "/Users/elangley/WebKit/Source/WebCore/ChangeLog")

+

+(defun get-block (stream)

+  (let ((header (read-line stream)))

+    (loop for next = (peek-char nil stream nil)

+       while (and next (whitespacep next))

+       collect (read-line stream) into lines

+       finally

+         (return (trim-whitespace

+                  (string-join (cons header lines)

+                               #\newline))))))

+

+(defun main ()

+  (let ((*changelog-path* (or (caddr sb-ext:*posix-argv*)

+                              *changelog-path*))

+        (search-string (cadr sb-ext:*posix-argv*)))

+    (handler-case (with-input-from-file (s *changelog-path*)

+                    (loop for next-block = (get-block s)

+                       when (search search-string next-block :test #'char-equal) do

+                         (format t "~&~a~%" next-block)))

+      (end-of-file (c) c))))

+

+;;; sbcl --disable-debugger --no-userinit --load $HOME/quicklisp/setup.lisp --eval '(ql:quickload (list :alexandria :serapeum :fwoar.lisputils))' --load /Users/elangley/git_repos/lisp-sandbox/changelog-filter.lisp --eval "(save-lisp-and-die "'"'"changelog-filter"'"'" :executable t :toplevel #'changelog-filter::main :compression t)"

new file mode 100644

@@ -0,0 +1,13 @@

+(defpackage :code-lookup

+  (:use :cl :serapeum :alexandria :fw.lu)

+  (:export ))

+(in-package :code-lookup)

+

+

+(defun call-with-auto-coercions (coercions cb)

+  (handler-bind ((type-error (lambda (c)

+                               (loop for ((from-type to-type) . coercion) in coercions

+                                  when (and (subtypep to-type (type-error-expected-type c))

+                                            (subtypep (type-of (type-error-datum c)) from-type))

+                                  do (store-value (funcall coercion (type-error-datum c)))))))

+    (funcall cb)))

new file mode 100644

@@ -0,0 +1,15 @@

+(defpackage :dotimes-printer

+  (:use :cl))

+(in-package :dotimes-printer)

+

+(dotimes (var count &optional result)

+  &body body)

+

+(defmacro destructure-dotimes ((var count &optional result) &body body)

+  `(translate

+    (produce-initializer ',var 0)

+    (produce-check ',var '< ',count)

+    (produce-increment ',)))

+

+(defun translate-dotimes (form)

+  ())

new file mode 100644

@@ -0,0 +1,19 @@

+(defpackage :garagiste-app

+  (:use :cl )

+  (:export ))

+(in-package :garagiste-app)

+

+(defun get-signin-page ()

+  (let ((c-j (make-instance 'drakma:cookie-jar)))

+    (values (plump:parse

+             (drakma:http-request "https://app.garagiste.com/users/sign_in"

+                                  :cookie-jar c-j))

+            c-j)))

+

+(defun extract-auth-token (doc)

+  (lquery:$1 (inline doc)

+             "form input[type=hidden][name=authenticity_token]"

+             (attr "value")))

+

+(defun login-garagiste (user pass auth-token)

+  )

new file mode 100644

@@ -0,0 +1,119 @@

+(defpackage :infer-type

+  (:use :cl :serapeum)

+  (:export ))

+(in-package :infer-type)

+

+(defclass type-env ()

+  ((%typedefs :initform (make-hash-table)

+              :initarg :typedefs

+              :reader typedefs)

+   (%typebindings :initform (make-hash-table)

+                  :initarg :type-bindings

+                  :reader typebindings)

+   (%values :initform (make-hash-table)

+            :reader values-)))

+

+(defparameter *type-env* (make-instance 'type-env))

+

+(defmacro with-types ((&rest types) (&rest defs) &body body)

+  `(let ((*type-env* (make-instance 'type-env

+                                    :typedefs

+                                    (alexandria:alist-hash-table ',(loop for (type def) in types

+                                                                      collect (cons type def)))

+                                    :type-bindings

+                                    (alexandria:alist-hash-table ',defs))))

+     ,@body))

+

+(defun lookup-type (type)

+  (gethash type (typedefs *type-env*)))

+

+(defun get-function-type (expr)

+  (gethash (car expr)

+           (typebindings *type-env*)))

+

+(defun is-type-variable (tyvar)

+  (and (symbolp tyvar)

+       (char= (elt (symbol-name tyvar)

+                   0)

+              #\?)))

+

+(defun is-bound-type-variable (tyvar)

+  (nth-value 1 (gethash tyvar (typebindings *type-env*))))

+

+(defun lookup-type-variable (tyvar)

+  (gethash tyvar (typebindings *type-env*)))

+

+(defun infer-simple-type (expr)

+  (loop for k being the hash-keys of (typebindings *type-env*)

+     using (hash-value v)

+     when (subtypep (type-of expr) v) do

+       (return k)))

+

+(defun infer-complex-type (expr)

+  (destructuring-bind (ret-type arg-types) (get-function-type expr)

+    ))

+

+(defun infer-type (expr)

+  (if (is-simple-expression expr)

+      (infer-simple-type expr)

+      (infer-complex-type expr)))

+

+(defun bind-type-variable (expr tyvar)

+  (setf (gethash tyvar (typebindings *type-env*))

+        (infer-type expr)))

+

+(defun check-type- (expr type)

+  (if (is-type-variable type)

+      (if (is-bound-type-variable type)

+          (check-type- expr

+                       (lookup-type-variable type))

+          (bind-type-variable expr type))

+      (if (is-simple-expression expr)

+          (check-simple-type expr type)

+          (check-complex-type expr type))))

+

+(defun is-simple-expression (expr)

+  (or (not (listp expr))

+      (eql (car expr)

+           'quote)))

+

+(defun check-simple-type (expr type)

+  (values (subtypep (type-of expr)

+                    (lookup-type type))

+          type))

+

+(defun check-complex-type (expr type)

+  (destructuring-bind (return-type arg-types) (get-function-type expr)

+    (values (and (lookup-type return-type)

+                 (subtypep (lookup-type return-type)

+                           (lookup-type type))

+                 (= (1- (length expr))

+                    (length arg-types))

+                 (every (lambda (arg-expr arg-type)

+                          (and (lookup-type arg-type)

+                               (check-type- arg-expr arg-type)))

+                        (cdr expr)

+                        arg-types))

+            return-type)))

+

+

+(defun foo (a b)

+  (check-type a number)

+  (check-type b number)

+  (+ a b))

+

+#+null

+(defmacro with-implicit-conversions ((&rest conversions) &body body)

+  `(let ((num-coercions 0)

+         (coercion-limit 10))

+     (handler-bind ((type-error (lambda (c)

+                                  (incf num-coercions)

+                                  (when (< num-coercions

+                                           coercion-limit)

+                                    (let ((datum (type-error-datum c))

+                                          (expected-type (type-error-expected-type c)))

+                                      (store-value

+                                       (cond ,@(loop for (type handler) in conversions

+                                                  collect `((subtypep ',type expected-type)

+                                                            (,handler datum))))))))))

+       ,@body)))

new file mode 100644

@@ -0,0 +1,80 @@

+(defpackage :labels-parser

+  (:use :cl )

+  (:export ))

+(in-package :labels-parser)

+

+(defmacro cond-switch* ((&rest bindings) &body clauses)

+  `(let* (,@bindings)

+    (cond ,@clauses)))

+

+(defun read-group (s)

+  (labels ((is-terminal-p (char)

+             (or (null char)

+                 (member char '(#\space #\) #\,))))

+           (peek ()

+             (peek-char nil *standard-input* nil))

+           (discard ()

+             (read-char *standard-input*))

+           (getch ()

+             (read-char *standard-input*))

+

+           (consume-whitespace (next)

+             (if (eql #\space (peek))

+                 (progn (read-char)

+                        (consume-whitespace next))

+                 (funcall next)))

+           (consume-matching (pred)

+             (if (funcall pred (peek))

+                 (getch)

+                 (error 'parse-fail)))

+           (consume-until (term-pred pred &optional accum)

+             (cond-switch* ((nc (peek)))

+               ((funcall term-pred nc)

+                (consume-whitespace

+                 (lambda () (reverse accum))))

+               (t

+                (consume-until term-pred pred

+                               (cons (consume-matching pred)

+                                     accum)))))

+           (consume-nonterminal (pred)

+             (consume-until #'is-terminal-p pred))

+

+           (read-symbol ()

+             (coerce (consume-nonterminal #'alphanumericp)

+                     'string))

+           (read-number ()

+             (parse-integer

+              (coerce (consume-nonterminal #'digit-char-p)

+                      'string)))

+           (read-primitive ()

+             (cond-switch* ((c (peek)))

+               ((null c) nil)

+               ((digit-char-p c) (read-number))

+               ((alpha-char-p c) (read-symbol))))

+           (read-list (&optional accum)

+             (cond-switch* ((next (read-primitive))

+                            (nc (peek)))

+               ((null next)

+                (if (eql #\) nc)

+                    (reverse accum)

+                    (error 'parse-fail)))

+               ((eql #\) nc)

+                (discard)

+                (reverse (cons next accum)))

+               (t

+                (read-list (cons next accum)))))

+

+           (read-main ()

+             (cond-switch* ((nc (peek)))

+               ((null nc) nil)

+               ((eql #\space nc) (read-char) (read-main))

+               ((eql nc #\()

+                (read-char)

+                (consume-whitespace

+                 (lambda () (read-list))))

+               (t (prog1 (read-primitive)

+                    (when (listen *standard-input*)

+                      (error 'parse-fail)))))))

+    (let ((*standard-input* s))

+      (read-main))))

+

new file mode 100644

Binary files /dev/null and b/lisp-sandbox.zip differ

new file mode 100644

new file mode 100644

@@ -0,0 +1,5 @@

+(defpackage :patmatch-paip

+  (:use :cl )

+  (:export ))

+(in-package :patmatch-paip)

+

new file mode 100644

@@ -0,0 +1,17 @@

+(defpackage :qtools-demo

+  (:use :cl))

+

+(in-package :qtools-demo)

+

+(defun make-slider ()

+  (prog1-bind (the-widget (make-instance 'qui:slider))

+    ))

+

+(defun main ()

+  (cl+qt:with-main-window (w (make-instance 'qui:panel-container))

+  (qui:add-widget (make-instance 'qui:panel :title "An empty panel :(") w)

+  (qui:add-widget (make-instance 'qui:panel :title "A slider, whoa!"

+                                 :center (make-slider)) w)

+  (qui:add-widget (make-instance 'qui:listing :title "A slider, whoa!"

+                                 :center (make-instance 'qui:slider)) w))

+)

new file mode 100644

@@ -0,0 +1 @@

+git-pick-patch:

new file mode 100644

@@ -0,0 +1,73 @@

+(defpackage :git-pick-patch

+  (:use :cl :alexandria :serapeum)

+  (:export ))

+(in-package :git-pick-patch)

+

+(defun read-header (inp)

+  (string-join (loop for line = (read-line inp nil)

+                  while line

+                  collect line

+                  until (eql #\@ (peek-char nil inp nil)))

+               #\newline))

+

+(defun read-hunk (inp)

+  (when (eql #\@

+             (peek-char nil inp nil))

+    (string-join (loop for line = (read-line inp nil)

+                    while line

+                    collect line

+                    until (member (peek-char nil inp nil) '(#\@ #\d)))

+                 #\newline)))

+

+(defun read-hunks (inp)

+  (loop for hunk = (read-hunk inp)

+     while hunk

+     collect hunk))

+

+(defun get-file-patch (inp)

+  (list (read-header inp)

+        (read-hunks inp)))

+

+(defun get-all-patches (inp)

+  (loop for patch = (get-file-patch inp)

+     for (header data) = patch

+     while (and (string/= header "")

+                (not (null data)))

+     collect patch))

+

+(defun filter-hunks (hunks predicate)

+  (remove-if-not predicate hunks))

+

+(defun filter-file-hunks (file-data predicate)

+  (let ((results (filter-hunks (cadr file-data)

+                               predicate)))

+    (when results

+      (list (car file-data)

+            results))))

+

+(defun filter-patch (patch-data predicate)

+  (remove-if #'null (mapcar (lambda (x)

+                              (filter-file-hunks x predicate))

+                            patch-data)))

+

+(defun combine-hunks (hunks)

+  (string-join hunks #\newline))

+

+(defun rebuild-file-patch (file-data)

+  (destructuring-bind (header hunks) file-data

+    (format nil "~a~%~a" header (combine-hunks hunks))))

+

+(defun rebuild-patch (patch-data)

+  (string-join (mapcar #'rebuild-file-patch patch-data)

+               #\newline))

+

+(defun main ()

+  (if (null (cadr sb-ext:*posix-argv*))

+      (format t "~&Must provide a pattern!")

+      (let* ((pattern (cadr sb-ext:*posix-argv*)))

+        (loop for patch = (get-file-patch *standard-input*)

+           for filtered = (when patch (filter-file-hunks patch

+                                                         (op (cl-ppcre:scan pattern _))))

+           until (equal patch '("" nil))

+           when filtered do

+             (format t "~&~a~&" (rebuild-file-patch filtered))))))

new file mode 100644

@@ -0,0 +1,5 @@

+(defpackage :typecheck

+  (:use :cl )

+  (:export ))

+(in-package :typecheck)

+

new file mode 100644

@@ -0,0 +1,123 @@

+(uiop:define-package :fwoar.zipfile

+  (:mix :cl :fwoar.lisputils)

+  (:export ))

+(in-package :fwoar.zipfile)

+

+(defun read-bytes (n s)

+  (with (seq (make-array n :element-type 'serapeum:octet))

+    (values seq

+            (read-sequence seq s))))

+

+(defun calculate-sizes (desc)

+  (reduce #'+ desc

+          :key #'cadr

+          :initial-value 0))

+

+(defun le->int (bytes)

+  (cadr

+   (reduce (op (destructuring-bind (count val) _1

+                 (list (1+ count)

+                       (+ val

+                          (ash _2

+                               (* count 8))))))

+           bytes

+           :initial-value (list 0 0))))

+

+(defun get-extractable-bytes (desc &optional (bindings ()))

+  (loop for ((name size . other) . rest) on (resolve-sizes desc bindings)

+     until (symbolp size)

+     collect (list* name size other) into extractable

+     finally (return (values extractable

+                             (append (serapeum:unsplice

+                                      (when (symbolp size)

+                                        (list* name size other)))

+                                     rest))))) 

+

+(defun resolve-sizes (desc extant-bindings)

+  (declare (optimize (debug 3)))

+  (loop with bindings = (copy-seq extant-bindings)

+     for (name size . rest) in desc

+     for resolved = (when (symbolp size)

+                      (cdr (assoc size bindings)))

+     when resolved do (push (cons name resolved)

+                            bindings)

+     if resolved collect (list* name resolved rest) into new-desc

+     else collect (list* name size rest) into new-desc

+     finally (return (values new-desc

+                             (remove-duplicates (append (mapcar (op (apply #'cons (subseq _ 0 2)))

+                                                                new-desc)

+                                                        bindings)

+                                                :key 'car

+                                                :from-end t)))))

+

+(defun extract-bytes (desc bytes)

+  (loop

+     with cur-idx = 0

+     for (name size . rest) in desc

+     for next-seq = (subseq bytes cur-idx

+                            (+ cur-idx size))

+     collect (cons name (if rest

+                            (funcall (car rest) next-seq)

+                            next-seq))

+     do (incf cur-idx size)))

+

+(defun parse-struct (desc s)

+  (let* ((struct-size (calculate-sizes desc))

+         (bytes (read-bytes struct-size s)))

+    (extract-bytes desc bytes)))

+

+(defun make-zipfile-stream (fn)

+  (open fn :element-type '(unsigned-byte 8)))

+

+

+(defun extract (raw-desc s &optional bindings)

+  (multiple-value-bind (desc remainder) (get-extractable-bytes raw-desc bindings)

+    (let ((next-segment (parse-struct desc s)))

+      (if remainder

+          (append next-segment

+                  (extract remainder s (append next-segment bindings)))

+          next-segment))))

+

+(defparameter *zip-local-file-header*

+  '((signature 4)

+    (version 2)

+    (flags 2)

+    (compression 2 le->int)

+    (mod-time 2)

+    (mod-date 2)

+    (crc-32 4)

+    (compressed-size 4 le->int)

+    (uncompressed-size 4 le->int)

+    (file-name-length 2 le->int)

+    (extra-field-length 2 le->int)

+    (file-name file-name-length babel:octets-to-string)

+    (extra-field extra-field-length)))

+

+(defun decode-file-data (metadata s)

+  (let ((crc-32 (le->int (cdr (assoc 'crc-32 metadata))))

+        (compressed-size (cdr (assoc 'compressed-size metadata)))

+        (uncompressed-size (cdr (assoc 'uncompressed-size metadata))))

+    (when (= 0 (+ crc-32 compressed-size uncompressed-size))

+      (error "bad zipfile: I don't support data descriptors yet..."))

+    (format t "~&COMPRESSED-SIZE: ~a~%" compressed-size)

+    (let ((compressed-data (read-bytes compressed-size s)))

+      (format t "~&...~%")

+      (values (serapeum:ecase-let (compression (cdr (assoc 'compression metadata)))

+                (0 compressed-data)

+                (8 (princ "decompress")

+                   (chipz:decompress nil (chipz:make-dstate 'chipz:deflate) compressed-data))

+                (t (error "unsupported compression ~a" compression)))

+              metadata))))

+

+(defun decode-a-file-if-name (pred s)

+  (let ((metadata (extract *zip-local-file-header* s)))

+    (values (if (funcall pred (cdr (assoc 'file-name metadata)))

+                (decode-file-data metadata s)

+                (progn (file-position s (+ (file-position s)

+                                           (cdr (assoc 'compressed-size metadata))))

+                       nil))

+            metadata)))

+

+(defun decode-a-file (s)

+  (let ((metadata (extract *zip-local-file-header* s)))

+    (decode-file-data metadata s)))