# HG changeset patch # User Steve Losh # Date 1485471268 0 # Node ID 326c2d62fcebfaa6598dcf445fce775f832ffbeb # Parent 5c5070c212695a5ff0e85a241381c8d46359a592 Get this shit compiling with the new cl-losh diff -r 5c5070c21269 -r 326c2d62fceb package.lisp --- a/package.lisp Tue Jan 17 18:37:07 2017 +0000 +++ b/package.lisp Thu Jan 26 22:54:28 2017 +0000 @@ -3,7 +3,6 @@ :cl :losh :iterate - :cl-arrows :sand.quickutils) (:export :average4)) @@ -11,7 +10,6 @@ (defpackage :sand.primes (:use :cl - :cl-arrows :losh :iterate :sand.quickutils @@ -24,7 +22,6 @@ :cl :losh :iterate - :cl-arrows :sand.quickutils :sand.utils)) @@ -33,7 +30,6 @@ :cl :losh :iterate - :cl-arrows :sandalphon.compiler-macro :sand.quickutils :sand.utils) @@ -48,7 +44,6 @@ :cl :losh :iterate - :cl-arrows :sand.quickutils :sand.utils)) @@ -57,7 +52,6 @@ :cl :losh :sand.quickutils - :cl-arrows :cl-fad :parenscript) (:shadowing-import-from :losh @@ -68,7 +62,6 @@ :cl :losh :iterate - :cl-arrows :sand.quickutils :sand.utils)) @@ -77,14 +70,12 @@ :cl :losh :iterate - :cl-arrows :sand.quickutils :sand.utils)) (defpackage :sand.dijkstra-maps (:use :cl - :cl-arrows :losh :iterate :sand.quickutils @@ -99,7 +90,6 @@ (defpackage :sand.graphs (:use :cl - :cl-arrows :losh :iterate :sand.quickutils @@ -110,7 +100,6 @@ (defpackage :sand.graphviz (:use :cl - :cl-arrows :losh :iterate :sand.quickutils @@ -121,12 +110,13 @@ (defpackage :sand.ropes (:use :cl - :cl-arrows :losh :iterate :trivia :sand.quickutils :sand.utils) + (:shadowing-import-from :losh + :<>) (:export )) @@ -142,7 +132,6 @@ (defpackage :sand.binary-decision-diagrams (:use :cl - :cl-arrows :losh :iterate :sand.graphviz @@ -154,7 +143,6 @@ (defpackage :sand.zero-suppressed-decision-diagrams (:use :cl - :cl-arrows :losh :iterate :sand.graphviz @@ -167,7 +155,6 @@ (defpackage :sand.huffman-trees (:use :cl - :cl-arrows :losh :iterate :sand.graphviz @@ -179,7 +166,6 @@ (defpackage :sand.streams (:use :cl - :cl-arrows :losh :iterate :sand.primes @@ -192,7 +178,6 @@ (defpackage :sand.ffi (:use :cl - :cl-arrows :losh :iterate :cffi @@ -204,7 +189,6 @@ (defpackage :sand.color-difference (:use :cl - :cl-arrows :losh :iterate :rs-colors @@ -216,7 +200,6 @@ (defpackage :sand.story (:use :cl - :cl-arrows :losh :iterate :sand.quickutils @@ -227,7 +210,6 @@ (defpackage :sand.number-letters (:use :cl - :cl-arrows :losh :iterate :function-cache @@ -239,7 +221,6 @@ (defpackage :sand.urn (:use :cl - :cl-arrows :losh :iterate :sand.quickutils @@ -250,7 +231,6 @@ (defpackage :sand.qud (:use :cl - :cl-arrows :losh :iterate :sand.quickutils @@ -261,7 +241,6 @@ (defpackage :sand.istruct (:use :cl - :cl-arrows :losh :iterate :sand.quickutils @@ -303,7 +282,6 @@ (defpackage :sand.profiling (:use :cl - :cl-arrows :losh :iterate :sand.quickutils @@ -341,6 +319,5 @@ :cl :losh :iterate - :cl-arrows :sand.quickutils :sand.utils)) diff -r 5c5070c21269 -r 326c2d62fceb src/istruct.lisp --- a/src/istruct.lisp Tue Jan 17 18:37:07 2017 +0000 +++ b/src/istruct.lisp Thu Jan 26 22:54:28 2017 +0000 @@ -50,46 +50,46 @@ ;;;; Definition --------------------------------------------------------------- -(defun required (name) - (error "Slot ~S is required" name)) - +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun required (name) + (error "Slot ~S is required" name)) -(defun build-slot (slot-spec) - (destructuring-bind (slot-name &key default type) slot-spec - `(,slot-name - ,(if default - default - `(required ',slot-name)) - :read-only t - ,@(when type `(:type ,type))))) + (defun build-slot (slot-spec) + (destructuring-bind (slot-name &key default type) slot-spec + `(,slot-name + ,(if default + default + `(required ',slot-name)) + :read-only t + ,@(when type `(:type ,type))))) -(defun build-immutable-struct-form (name slots) - `(defstruct ,name - ,@(mapcar #'build-slot slots))) + (defun build-immutable-struct-form (name slots) + `(defstruct ,name + ,@(mapcar #'build-slot slots))) -(defun build-iset (name slots) - `(defmethod iset ((instance ,name) slot new-value) - (,(symb 'make- name) - ,@(iterate (for (slot . nil) :in slots) - (collect (ensure-keyword slot)) - (collect `(if (eq slot ',slot) - new-value - (slot-value instance ',slot))))))) + (defun build-iset (name slots) + `(defmethod iset ((instance ,name) slot new-value) + (,(symb 'make- name) + ,@(iterate (for (slot . nil) :in slots) + (collect (ensure-keyword slot)) + (collect `(if (eq slot ',slot) + new-value + (slot-value instance ',slot))))))) -(defun build-equal? (name slots) - `(defmethod equal? ((a ,name) (b ,name)) - (and ,@(iterate (for (slot . nil) :in slots) - (collect `(equal? - (slot-value a ',slot) - (slot-value b ',slot))))))) + (defun build-equal? (name slots) + `(defmethod equal? ((a ,name) (b ,name)) + (and ,@(iterate (for (slot . nil) :in slots) + (collect `(equal? + (slot-value a ',slot) + (slot-value b ',slot))))))) -(defun build-constructor (name slots) - (let ((slot-names (mapcar #'first slots))) - `(defun ,name ,slot-names - (,(symb 'make- name) - ,@(iterate (for slot :in slot-names) - (collect (ensure-keyword slot)) - (collect slot)))))) + (defun build-constructor (name slots) + (let ((slot-names (mapcar #'first slots))) + `(defun ,name ,slot-names + (,(symb 'make- name) + ,@(iterate (for slot :in slot-names) + (collect (ensure-keyword slot)) + (collect slot))))))) (defmacro define-istruct (name-and-options &rest slots) diff -r 5c5070c21269 -r 326c2d62fceb src/random-numbers.lisp --- a/src/random-numbers.lisp Tue Jan 17 18:37:07 2017 +0000 +++ b/src/random-numbers.lisp Thu Jan 26 22:54:28 2017 +0000 @@ -31,23 +31,26 @@ (type positive-fixnum modulus multiplier increment)) (let ((val (mod (logxor seed multiplier) modulus))) - (dlambda - (:next () - (ldb (byte 32 16) ; java's j.u.Random only gives out 32 high-order bits - (setf val (mod (+ (* val multiplier) increment) - modulus)))) - (:modulus () modulus)))) + (lambda (arg) + (case arg + (:next + (ldb (byte 32 16) ; java's j.u.Random only gives out 32 high-order bits + (setf val (mod (+ (* val multiplier) increment) + modulus)))) + (:modulus + modulus))))) (defun make-linear-congruential-rng (modulus multiplier increment seed) (declare (type nonnegative-fixnum seed) (type positive-fixnum modulus multiplier increment)) (let ((val (mod (logxor seed multiplier) modulus))) - (dlambda - (:next () - (setf val (mod (+ (* val multiplier) increment) - modulus))) - (:modulus () modulus)))) + (lambda (arg) + (case arg + (:next + (setf val (mod (+ (* val multiplier) increment) + modulus))) + (:modulus modulus))))) (declaim (inline rng-next rng-modulus))