;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
;;;
;;; file-monitor.lisp --- Monitor files on disk.
;;;

(in-package :net.sockets)

(defclass file-monitor ()
  ((file :initform (error "Must supply a file name")
         :initarg :file :accessor file-of)
   (timestamp :initarg :timestamp :accessor timestamp-of)
   (update-fn :initarg :update-fn :accessor update-fn-of)
   (lock      :initarg :lock      :accessor lock-of))
  (:default-initargs :timestamp 0))

(defmethod print-object ((monitor file-monitor) stream)
  (print-unreadable-object (monitor stream :type nil :identity nil)
    (format stream "File monitor for ~S" (file-of monitor))))

(defun monitor-oldp (monitor)
  (declare (type file-monitor monitor))
  (let ((mtime (file-write-date (file-of monitor))))
    (values (< (timestamp-of monitor) mtime)
            mtime)))

(defgeneric update-monitor (monitor)
  (:method ((monitor file-monitor))
    (bt:with-lock-held ((lock-of monitor))
      (multiple-value-bind (oldp mtime) (monitor-oldp monitor)
        (when oldp
          (funcall (update-fn-of monitor) (file-of monitor))
          (multiple-value-prog1
              (values (timestamp-of monitor) mtime)
            (setf (timestamp-of monitor) mtime)))))))

Add default initarg to :LOCK of FILE-MONITOR class.

;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
;;;
;;; file-monitor.lisp --- Monitor files on disk.
;;;

(in-package :net.sockets)

(defclass file-monitor ()
  ((file :initform (error "Must supply a file name")
         :initarg :file :accessor file-of)
   (timestamp :initarg :timestamp :accessor timestamp-of)
   (update-fn :initarg :update-fn :accessor update-fn-of)
   (lock      :initarg :lock      :accessor lock-of))
  (:default-initargs :timestamp 0
                     :lock (bt:make-lock)))

(defmethod print-object ((monitor file-monitor) stream)
  (print-unreadable-object (monitor stream :type nil :identity nil)
    (format stream "File monitor for ~S" (file-of monitor))))

(defun monitor-oldp (monitor)
  (declare (type file-monitor monitor))
  (let ((mtime (file-write-date (file-of monitor))))
    (values (< (timestamp-of monitor) mtime)
            mtime)))

(defgeneric update-monitor (monitor)
  (:method ((monitor file-monitor))
    (bt:with-lock-held ((lock-of monitor))
      (multiple-value-bind (oldp mtime) (monitor-oldp monitor)
        (when oldp
          (funcall (update-fn-of monitor) (file-of monitor))
          (multiple-value-prog1
              (values (timestamp-of monitor) mtime)
            (setf (timestamp-of monitor) mtime)))))))


(cl:in-package #:sicl-extrinsic-hir-compiler)

(defun rp (filename)
  (asdf:system-relative-pathname :sicl-extrinsic-hir-compiler filename))

(load (rp "../../Evaluation-and-compilation/lambda.lisp"))
(load (rp "../../Environment/multiple-value-bind.lisp"))
(load (rp "../../Data-and-control-flow/setf.lisp"))
(load (rp "../../Environment/defun.lisp"))

Load the definition of CL:FBOUNDP.

(cl:in-package #:sicl-extrinsic-hir-compiler)

(defun rp (filename)
  (asdf:system-relative-pathname :sicl-extrinsic-hir-compiler filename))

(load (rp "../../Evaluation-and-compilation/lambda.lisp"))
(load (rp "../../Environment/multiple-value-bind.lisp"))
(load (rp "../../Data-and-control-flow/setf.lisp"))
(load (rp "../../Environment/defun.lisp"))
(load (rp "../../Data-and-control-flow/fboundp.lisp"))


(in-package :cqlcl)

(defclass connection ()
  ;; TODO maybe this should hold an instance of a parser
  ((conn :accessor conn :initarg :conn)))

(defun make-connection (&optional (host "localhost") (port 9042))
  (let ((conn (usocket:socket-stream
               (usocket:socket-connect host port :element-type '(unsigned-byte 8)))))
    (options conn)
    (force-output conn)
    (parse-packet (read-single-packet conn))
    (make-instance 'connection :conn conn)))

Add TODO for passing in version info and compression type

(in-package :cqlcl)

(defclass connection ()
  ;; TODO maybe this should hold an instance of a parser
  ((conn :accessor conn :initarg :conn)))

(defun make-connection (&optional (host "localhost") (port 9042)); TODO: &key version compression)
  (let ((conn (usocket:socket-stream
               (usocket:socket-connect host port :element-type '(unsigned-byte 8)))))
    (options conn)
    (force-output conn)
    (parse-packet (read-single-packet conn))
    (make-instance 'connection :conn conn)))


(cl:in-package #:asdf-user)

(defsystem :sicl-boot-phase1
  :depends-on (:sicl-extrinsic-environment)
  :serial t
  :components
  ((:file "packages")
   (:file "temporary-standard-class")
   (:file "fill")
   (:file "environment")))

Remove component defining temporary version of STANDARD-CLASS.

(cl:in-package #:asdf-user)

(defsystem :sicl-boot-phase1
  :depends-on (:sicl-extrinsic-environment)
  :serial t
  :components
  ((:file "packages")
   (:file "fill")
   (:file "environment")))


(defpackage :mcclim-freetype
    (:use :climi :clim :clim-lisp)
    (:export :*freetype-font-path*)
    (:import-from #+(or cmu scl) :alien
                  #+sbcl :sb-alien
                  :slot :make-alien :alien :deref))

Use cl:defpackage for the freetype package, no matter what.

(cl:defpackage :mcclim-freetype
    (:use :climi :clim :clim-lisp)
    (:export :*freetype-font-path*)
    (:import-from #+(or cmu scl) :alien
                  #+sbcl :sb-alien
                  :slot :make-alien :alien :deref))


(in-package :6502)

(defparameter *benchmark*
  '(;; Clear the Decimal and Carry status bits
    #xd8       ; $0000 d8    CLD
    #x18       ; $0001 18    CLC
    ;; Set the Accumulator and X and Y regs to zero
    #xa9 #x00  ; $0002 a9 00 LDA #$00
    #xa2 #x00  ; $0004 a2 00 LDX #$00
    #xa0 #x00  ; $0006 a0 00 LDY #$00
    ;; Increment Y, then branch to 0x08
    #xc8       ; $0008 c8    INY
    #xd0 #xfd  ; $0009 d0 fd BNE $0008
    ;; Increment X until zero bit set, branch to 0x06, delete y and loop
    #xe8       ; $000b e8    INX
    #xd0 #xf8  ; $000c d0 f8 BNE $0006
    ;; Add 1 with carry to accumulator and rewind to 0x04
    #x69 #x01  ; $000e 69 01 ADC #$01
    #xd0 #xf2  ; $0010 d0 f2 BNE $0004
    ;; set break and interrupt, set PC to 0, subtract from accumulator.
    #x00       ; $0012 00    BRK
    #xed)      ; $0013 ed    SBC
  "Should leave the Y register with the value 47.")

Improve *benchmark* and its documentation.

(in-package :6502)

(defparameter *benchmark*
  '(;; Clear the Decimal and Carry status bits
    #xd8       ; $0000 d8    CLD
    #x18       ; $0001 18    CLC
    ;; Set the Accumulator and X and Y regs to zero
    #xa9 #x00  ; $0002 a9 00 LDA #$00
    #xa2 #x00  ; $0004 a2 00 LDX #$00
    #xa0 #x00  ; $0006 a0 00 LDY #$00
    ;; Increment Y until it wraps around to zero, then proceed to 0x0b
    #xc8       ; $0008 c8    INY
    #xd0 #xfd  ; $0009 d0 fd BNE $0008
    ;; subtract the sum of value at 0x01+carry from accumulator and halt.
    #xed #x01  ; $000b ed 01 SBC #$01
    #x00)      ; $000d 00    BRK
  "Should leave the Accumulator with the value 231.")


;;;; $Id$
;;;; $URL$

;;;; See the LICENSE file for licensing information.

#+lispworks (cl:require "comm")

(cl:eval-when (:execute :load-toplevel :compile-toplevel)
  (cl:defpackage :usocket
      (:use :cl)
    (:export #:*wildcard-host*
             #:*auto-port*

             #:socket-connect ; socket constructors and methods
             #:socket-listen
             #:socket-accept
             #:socket-close
             #:wait-for-input
             #:get-local-address
             #:get-peer-address
             #:get-local-port
             #:get-peer-port
             #:get-local-name
             #:get-peer-name

             #:with-connected-socket ; convenience macros
             #:with-server-socket
             #:with-client-socket
             #:with-socket-listener

             #:usocket ; socket object and accessors
             #:stream-usocket
             #:stream-server-usocket
             #:socket
             #:socket-stream

             #:host-byte-order ; IP(v4) utility functions
             #:hbo-to-dotted-quad
             #:hbo-to-vector-quad
             #:vector-quad-to-dotted-quad
             #:dotted-quad-to-vector-quad
             #:ip=
             #:ip/=

             #:socket-condition ; conditions
             #:socket-error ; errors
             #:unknown-condition
             #:unknown-error)))

Add missing symbols to the export list.

;;;; $Id$
;;;; $URL$

;;;; See the LICENSE file for licensing information.

#+lispworks (cl:require "comm")

(cl:eval-when (:execute :load-toplevel :compile-toplevel)
  (cl:defpackage :usocket
      (:use :cl)
    (:export #:*wildcard-host*
             #:*auto-port*

             #:socket-connect ; socket constructors and methods
             #:socket-listen
             #:socket-accept
             #:socket-close
             #:wait-for-input
             #:get-local-address
             #:get-peer-address
             #:get-local-port
             #:get-peer-port
             #:get-local-name
             #:get-peer-name

             #:with-connected-socket ; convenience macros
             #:with-server-socket
             #:with-client-socket
             #:with-socket-listener

             #:usocket ; socket object and accessors
             #:stream-usocket
             #:stream-server-usocket
             #:socket
             #:socket-stream

             #:host-byte-order ; IP(v4) utility functions
             #:hbo-to-dotted-quad
             #:hbo-to-vector-quad
             #:vector-quad-to-dotted-quad
             #:dotted-quad-to-vector-quad
             #:ip=
             #:ip/=

             #:socket-condition ; conditions
             #:ns-condition
             #:socket-error ; errors
             #:ns-error
             #:unknown-condition
             #:ns-unknown-condition
             #:unknown-error
             #:ns-unknown-error)))


(cl:in-package #:common-lisp-user)

(asdf:defsystem :cleavir-test-utilities
  :depends-on (:cleavir-utilities)
  :components
  ((:file "packages")
   (:file "test-utilities" :depends-on ("packages"))))

Define system in package ASDF-USER.

(cl:in-package #:asdf-user)

(defsystem :cleavir-test-utilities
  :depends-on (:cleavir-utilities)
  :components
  ((:file "packages")
   (:file "test-utilities" :depends-on ("packages"))))


(defvar *dist-url* "http://beta.quicklisp.org/dist/quicklisp/2016-08-25/distinfo.txt")

(load "quicklisp.lisp")

(quicklisp-quickstart:install :path "/opt/app-root/quicklisp/" :dist-url *dist-url*)

; Pre-load/compile useful content...
(ql:quickload :hunchentoot)

(with-open-file (out "/opt/app-root/.sbclrc" :direction :output)
  (format out "(load \"/opt/app-root/quicklisp\/setup.lisp\")"))

Add swank. Uses port 4005.

(defvar *dist-url* "http://beta.quicklisp.org/dist/quicklisp/2016-08-25/distinfo.txt")

(load "quicklisp.lisp")

(quicklisp-quickstart:install :path "/opt/app-root/quicklisp/" :dist-url *dist-url*)

; Pre-load/compile useful content...
(ql:quickload :hunchentoot)
(ql:quickload :swank)

(with-open-file (out "/opt/app-root/.sbclrc" :direction :output)
  (format out "(load \"/opt/app-root/quicklisp\/setup.lisp\")")
  (format out "(swank:create-server :port 4005 :dont-close t :coding-system \"utf-8-unix\")"))


(in-package #:eloquent.mvc.response)

(defun respond (body
                &key
                  (encoder #'identity)
                  (headers '())
                  (status 200))
  (make-instance '<response>
                 :body (funcall encoder body)
                 :status status
                 :headers headers))

(defun respond-json (body
                     &key
                       (headers '())
                       (status 200))
  "Encoding body into JSON and send response with at least the header Content-Type equals \"application/json\""
  (setf headers
        (override-header headers :content-type "application/json"))
  (respond
   (cl-json:encode-json-to-string body)
   :headers headers
   :status status))

Support passing keyword as encoder to RESPOND

(in-package #:eloquent.mvc.response)

(defun respond (body
                &key
                  (encoder #'identity)
                  (headers '())
                  (status 200))
  (when (keywordp encoder)
    (setf encoder (make-encoder encoder)))
  (make-instance '<response>
                 :body (funcall encoder body)
                 :status status
                 :headers headers))

(defun respond-json (body
                     &key
                       (headers '())
                       (status 200))
  "Encoding body into JSON and send response with at least the header Content-Type equals \"application/json\""
  (setf headers
        (override-header headers :content-type "application/json"))
  (respond
   (cl-json:encode-json-to-string body)
   :headers headers
   :status status))


(defpackage cl21)
(in-package :cl21)

(cl:dolist (package-name '(:cl21.core))
  (cl:let ((package (cl:find-package package-name)))
    (cl:unless package
      (cl:error "Package \"~A\" doesn't exist." package-name))
    (cl:do-external-symbols (symbol package)
      (cl:shadowing-import symbol)
      (cl:export symbol))))

(in-package :cl-user)
(defpackage cl21-user
  (:use :cl21))

Fix error 'The function CL21.CORE.PACKAGE:IN-PACKAGE is undefined.' by sbcl.

(defpackage cl21)
(cl:in-package :cl21)

(cl:dolist (package-name '(:cl21.core))
  (cl:let ((package (cl:find-package package-name)))
    (cl:unless package
      (cl:error "Package \"~A\" doesn't exist." package-name))
    (cl:do-external-symbols (symbol package)
      (cl:shadowing-import symbol)
      (cl:export symbol))))

(cl:in-package :cl-user)
(defpackage cl21-user
  (:use :cl21))


(in-package #:eloquent.mvc.response)

(defgeneric make-encoder (encoder)
  (:documentation "Returns a function for encoding a value into a string."))

(defmethod make-encoder ((encoder (eql :json-plist)))
  "Returns a function for encoding a PLIST into a JSON string."
  #'cl-json:encode-json-plist-to-string)

(defmethod make-encoder ((encoder (eql :json-plist-list)))
  "Returns a function for encoding a list consist of plist into a JSON string."
  (lambda (list)
    (check-type list list)
    (with-output-to-string (s)
      (cl-json:with-array (s)
        (dolist (e list)
          (cl-json:encode-json-plist e s))))))

Fix a bug: add comma when serializing plist into JSON

(in-package #:eloquent.mvc.response)

(defgeneric make-encoder (encoder)
  (:documentation "Returns a function for encoding a value into a string."))

(defmethod make-encoder ((encoder (eql :json-plist)))
  "Returns a function for encoding a PLIST into a JSON string."
  #'cl-json:encode-json-plist-to-string)

(defmethod make-encoder ((encoder (eql :json-plist-list)))
  "Returns a function for encoding a list consist of plist into a JSON string."
  (lambda (list)
    (check-type list list)
    (with-output-to-string (s)
      (json:with-array (s)
        (loop
           :for rest :on list
           :do (json:encode-json-plist (first rest) s)
           :when (rest rest) :do (princ "," s))))))


(cl:in-package #:clump-2-3-tree)

(defclass tree ()
  ((%contents :initform nil :accessor contents)
   (%leaf-class :initarg :leaf-class :reader leaf-class)
   (%2-node-class :initarg :2-node-class :reader 2-node-class)
   (%3-node-class :initarg :3-node-class :reader 3-node-class)))

(defclass node ()
  ((%parent :initarg :parent :accessor parent)
   (%tree :initarg :tree :reader tree)))

(defclass leaf (node)
  ((%contents :initarg :contents :accessor contents)))

(defclass 2-node (node)
  ((%left :initarg :left :accessor left)
   (%right :initarg :right :accessor right)))

(defclass 3-node (node)
  ((%left :initarg :left :accessor left)
   (%middle :initarg :middle :accessor middle)
   (%right :initarg :right :accessor right)))

Define generic function 2-NODE-P with two methods.

(cl:in-package #:clump-2-3-tree)

(defclass tree ()
  ((%contents :initform nil :accessor contents)
   (%leaf-class :initarg :leaf-class :reader leaf-class)
   (%2-node-class :initarg :2-node-class :reader 2-node-class)
   (%3-node-class :initarg :3-node-class :reader 3-node-class)))

(defclass node ()
  ((%parent :initarg :parent :accessor parent)
   (%tree :initarg :tree :reader tree)))

(defclass leaf (node)
  ((%contents :initarg :contents :accessor contents)))

(defclass 2-node (node)
  ((%left :initarg :left :accessor left)
   (%right :initarg :right :accessor right)))

(defgeneric 2-node-p (object)
  (:method (object) nil)
  (:method ((node 2-node)) t))

(defclass 3-node (node)
  ((%left :initarg :left :accessor left)
   (%middle :initarg :middle :accessor middle)
   (%right :initarg :right :accessor right)))


;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-

(defsystem :swap-bytes
  :defsystem-depends-on (:madeira-port :trivial-features)
  :depends-on (:trivial-features)
  :serial t
  :components ((:file "package")
               (:madeira-port "ccl"
                :when (:and :ccl (:or :x86 :x86-64)))
               (:madeira-port "sbcl-defknowns"
                :when (:and :sbcl (:or :x86 :x86-64)))
               (:madeira-port "sbcl-vops"
                :when (:and :sbcl (:or :x86 :x86-64)))
               (:madeira-port "sbcl"
                :when (:and :sbcl (:or :x86 :x86-64)))
               (:madeira-port "portable"
                :when (:not (:or (:and :ccl (:or :x86 :x86-64))
                                 (:and :sbcl (:or :x86 :x86-64)))))))

Use direct dependencies in ASDF

;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-

(defsystem :swap-bytes
  :defsystem-depends-on (:madeira-port :trivial-features)
  :depends-on (:trivial-features)
  :components ((:file "package")
               (:madeira-port "ccl"
                :when (:and :ccl (:or :x86 :x86-64))
                :depends-on ("package"))
               (:madeira-port "sbcl-defknowns"
                :when (:and :sbcl (:or :x86 :x86-64))
                :depends-on ("package"))
               (:madeira-port "sbcl-vops"
                :when (:and :sbcl (:or :x86 :x86-64))
                :depends-on ("package" "sbcl-defknowns"))
               (:madeira-port "sbcl"
                :when (:and :sbcl (:or :x86 :x86-64))
                :depends-on ("package" "sbcl-defknowns" "sbcl-vops"))
               (:madeira-port "portable"
                :when (:not (:or (:and :ccl (:or :x86 :x86-64))
                                 (:and :sbcl (:or :x86 :x86-64))))
                :depends-on ("package" "ccl" "sbcl"))))


;;;; repl-utilities.asd

(asdf:defsystem #:repl-utilities
  :serial t
  :description "Ease common tasks at the REPL."
  :license "BSD 2-clause"
  :author "Matt Niemeir"
  :components ((:file "package")
	       (:file "utils")
               (:file "repl-utilities")))

Add email in asdf system author field

;;;; repl-utilities.asd

(asdf:defsystem #:repl-utilities
  :serial t
  :description "Ease common tasks at the REPL."
  :license "BSD 2-clause"
  :author "Matt Niemeir <matt.niemeir@gmail.com>"
  :components ((:file "package")
	       (:file "utils")
               (:file "repl-utilities")))


(in-package :lispkit)

(defparameter *current-tab* nil)

(defun load-url (url &optional view)
  (webkit.foreign:webkit-web-view-load-uri
   (or view *current-tab*) url))

(defun event-as-string (event)
  (with-gdk-event-slots (state string) event
    (print (list state string))))

(let ((key-events nil))

  (defun all-events ()
    key-events)

  (defun events-as-string (events)
    (mapcar #'event-as-string events))

  (defun handle-key (window event)
    (declare (ignore window))
    (push event key-events)
    (events-as-string key-events)))

(defun main (&rest args)
  (declare (ignore args))
  (within-main-loop
    (let* ((ui     (load-ui-from-file "main.ui"))
           (window (gtk:gtk-builder-get-object ui "mainwindow"))
           (frame  (gtk:gtk-builder-get-object ui "scrolledwindow"))
           (view   (setq *current-tab*
                         (webkit.foreign:webkit-web-view-new))))
      (gtk-container-add frame view)
      (g-signal-connect window "key_press_event"
                        #'handle-key)
      (load-url "http://www.github.com/AeroNotix/lispkit")
      (gtk-widget-show-all window))))

Return nil in keypress handler

(in-package :lispkit)

(defparameter *current-tab* nil)

(defun load-url (url &optional view)
  (webkit.foreign:webkit-web-view-load-uri
   (or view *current-tab*) url))

(defun event-as-string (event)
  (with-gdk-event-slots (state string) event
    (print (list state string))))

(let ((key-events nil))

  (defun all-events ()
    key-events)

  (defun events-as-string (events)
    (mapcar #'event-as-string events))

  (defun handle-key (window event)
    (declare (ignore window))
    (push event key-events)
    (events-as-string key-events)
    nil))

(defun main (&rest args)
  (declare (ignore args))
  (within-main-loop
    (let* ((ui     (load-ui-from-file "main.ui"))
           (window (gtk:gtk-builder-get-object ui "mainwindow"))
           (frame  (gtk:gtk-builder-get-object ui "scrolledwindow"))
           (view   (setq *current-tab*
                         (webkit.foreign:webkit-web-view-new))))
      (gtk-container-add frame view)
      (g-signal-connect window "key_press_event"
                        #'handle-key)
      (load-url "http://www.github.com/AeroNotix/lispkit")
      (gtk-widget-show-all window))))


(defpackage :ps2js
  (:use #:cl
        #:uiop/pathname
        #:uiop/filesystem
        #:uiop/run-program
        #:cl-fsnotify
        #:alexandria)
  (:export #:bundle-vendor
           #:bundle-main
           #:minify-js
           #:watch-parenscript
           #:unwatch-parenscript)
  (:documentation "Automatically compile Parenscript files to
JavaScript and bundle."))

Fix export list to include specials

(defpackage :ps2js
  (:use #:cl
        #:uiop/pathname
        #:uiop/filesystem
        #:uiop/run-program
        #:cl-fsnotify
        #:alexandria)
  ;;; You are probably best off using package qualified names rather
  ;;; than importing all of this mess...
  (:export #:*ps-dir*
           #:*js-dir*
           #:*main-file*
           #:*npm-dir*
           #:*node-dependencies*
           #:*browserify*
           #:*uglifyjs*
           #:*js-beautify-cmd*
           #:*vendor-bundle-file*
           #:*main-bundle-file*
           #:*sleep-time*
           #:bundle-vendor
           #:bundle-main
           #:minify-js
           #:watch-parenscript
           #:unwatch-parenscript)
  (:documentation "Automatically compile Parenscript files to
JavaScript and bundle."))


;;;; Copyright (c) 2008 - 2013
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; all rights reserved.
;;;;
;;;; Permission is hereby granted to use this software for any
;;;; purpose, including using, modifying, and redistributing it.
;;;;
;;;; The software is provided "as-is" with no warranty.  The user of
;;;; this software assumes any responsibility of the consequences.

;;;; This file is part of the conditionals module of the SICL project.
;;;; See the file SICL.text for a description of the project.
;;;; See the file conditionals.text for a description of the module.

(cl:in-package #:common-lisp-user)

(asdf:defsystem :sicl-conditionals-test
  :depends-on (:sicl-conditionals)
  :components
  ((:file "test" :depends-on ())))

Define ASDF system in package ASDF-USER.

;;;; Copyright (c) 2008 - 2013
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; all rights reserved.
;;;;
;;;; Permission is hereby granted to use this software for any
;;;; purpose, including using, modifying, and redistributing it.
;;;;
;;;; The software is provided "as-is" with no warranty.  The user of
;;;; this software assumes any responsibility of the consequences.

;;;; This file is part of the conditionals module of the SICL project.
;;;; See the file SICL.text for a description of the project.
;;;; See the file conditionals.text for a description of the module.

(cl:in-package #:asdf-user)

(defsystem :sicl-conditionals-test
  :depends-on (:sicl-conditionals)
  :components
  ((:file "test" :depends-on ())))


;; Common Lisp Script
;; Manoel Vilela

(defpackage :lisp-chat-config
  (:use :cl)
  (:export :*debug*
           :*host*
           :*port*))

(in-package :lisp-chat-config)

(defparameter *debug* t)
(defparameter *host* "chat.lerax.me")
(defparameter *port* 5558)

Use 0.0.0.0 as default *host*

;; Common Lisp Script
;; Manoel Vilela

(defpackage :lisp-chat-config
  (:use :cl)
  (:export :*debug*
           :*host*
           :*port*))

(in-package :lisp-chat-config)

(defparameter *debug* t)
(defparameter *host* "0.0.0.0")
(defparameter *port* 5558)


(defbuiltin sys-image-create (pathname fun)
  (sb-ext:save-lisp-and-die pathname
                            :toplevel (lambda ()
                                        (cl:funcall fun))))

(defbuiltin %start-core ()
  (setq *launchfile* (cadr (| sb-ext:*posix-argv*
;                             #+SBCL sb-ext:*posix-argv*
;                             #+LISPWORKS system:*line-arguments-list*
;                             #+CMU extensions:*command-line-words*
                             nil))))

Switch to package :TRE to be safe.

(defbuiltin sys-image-create (pathname fun)
  (sb-ext:save-lisp-and-die pathname
                            :toplevel (lambda ()
                                        (cl:funcall fun))))

(defbuiltin %start-core ()
  (cl:use-package :tre)
  (setq *launchfile* (cadr (| sb-ext:*posix-argv*
;                             #+SBCL sb-ext:*posix-argv*
;                             #+LISPWORKS system:*line-arguments-list*
;                             #+CMU extensions:*command-line-words*
                             nil))))


(asdf:defsystem #:explicit-bind

  :author "Jean-Philippe Paradis <hexstream@gmail.com>"

  ;; See the UNLICENSE file for details.
  :license "Public Domain"

  :description "UNSUPPORTED. UNSTABLE? INCOMPLETE? Effectively enables intermixing of any number of LET, LET*, (an enhanced version of) FLET, MULTIPLE-VALUE-BIND and DESTRUCTURING-BIND constructs, at the cost of only one level of indentation."

  :version "0.1"
  :components ((:file "package")

	       (:file "with-shadowed-bindings"
                      :depends-on ("package"))
	       (:file "flet-star"
                      :depends-on ("package"))

               (:file "bubble-expand"
                      :depends-on ("package"))
               (:file "expand"
                      :depends-on ("package"
                                   "bubble-expand"))

	       (:file "merge"
                      :depends-on ("package"))
	       (:file "main"
                      :depends-on ("package"
                                   "expand"
                                   "merge"))))

Revert back to :serial t.

(asdf:defsystem #:explicit-bind

  :author "Jean-Philippe Paradis <hexstream@gmail.com>"

  ;; See the UNLICENSE file for details.
  :license "Public Domain"

  :description "UNSUPPORTED. UNSTABLE? INCOMPLETE? Effectively enables intermixing of any number of LET, LET*, (an enhanced version of) FLET, MULTIPLE-VALUE-BIND and DESTRUCTURING-BIND constructs, at the cost of only one level of indentation."

  :version "0.1"
  :serial cl:t
  :components ((:file "package")

	       (:file "with-shadowed-bindings")
	       (:file "flet-star")

               (:file "bubble-expand")
               (:file "expand")

	       (:file "merge")
	       (:file "main")))


(cl:in-package #:asdf-user)

(defsystem :sicl-compiler-test-utilities
  :depends-on (:sicl-compiler-utilities)
  :components
  ((:file "packages")
   (:file "test-utilities" :depends-on ("packages"))))

Use system option :SERIAL T.

(cl:in-package #:asdf-user)

(defsystem :sicl-compiler-test-utilities
  :depends-on (:sicl-compiler-utilities)
  :serial t
  :components
  ((:file "packages")
   (:file "test-utilities")))


(cl:defpackage #:enhanced-eval-when_tests
  (:use #:cl #:parachute)
  (:shadowing-import-from #:enhanced-eval-when #:eval-when))

(cl:in-package #:enhanced-eval-when_tests)

(defmacro test-passthrough (situations)
  `(is equal
       (macroexpand-1 '(eval-when ,situations do-it))
       '(cl:eval-when ,situations do-it)))

(define-test "enhanced-eval-when"
  (is equal
      (macroexpand-1 '(eval-when t do-it))
      '(cl:eval-when (:compile-toplevel :load-toplevel :execute)
        do-it))
  (test-passthrough '())
  (test-passthrough '(:compile-toplevel))
  (test-passthrough '(:load-toplevel))
  (test-passthrough '(:execute))
  (test-passthrough '(:compile-toplevel :load-toplevel))
  (test-passthrough '(:load-toplevel :execute))
  (test-passthrough '(:compile-toplevel :execute)))

Use proper argument order for IS.

(cl:defpackage #:enhanced-eval-when_tests
  (:use #:cl #:parachute)
  (:shadowing-import-from #:enhanced-eval-when #:eval-when))

(cl:in-package #:enhanced-eval-when_tests)

(defmacro test-passthrough (situations)
  `(is equal '(cl:eval-when ,situations do-it)
       (macroexpand-1 '(eval-when ,situations do-it))))

(define-test "enhanced-eval-when"
  (is equal
      (macroexpand-1 '(eval-when t do-it))
      '(cl:eval-when (:compile-toplevel :load-toplevel :execute)
        do-it))
  (test-passthrough '())
  (test-passthrough '(:compile-toplevel))
  (test-passthrough '(:load-toplevel))
  (test-passthrough '(:execute))
  (test-passthrough '(:compile-toplevel :load-toplevel))
  (test-passthrough '(:load-toplevel :execute))
  (test-passthrough '(:compile-toplevel :execute)))


(cl:in-package #:sicl-extrinsic-hir-compiler)

(defparameter *global-environment*
  (make-instance 'environment))

Rename global variable holding global environment.

(cl:in-package #:sicl-extrinsic-hir-compiler)

(defparameter *environment* (make-instance 'environment))


(cl:in-package #:sicl-clos)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class STANDARD-WRITER-METHOD.

(defclass standard-writer-method (standard-accessor-method)
  ())

Add copyright dates and license statement.

;;;; Copyright (c) 2013 - 2015
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or
;;;; without modification, are permitted provided that the following
;;;; conditions are met:
;;;;
;;;; 1. Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above
;;;;    copyright notice, this list of conditions and the following
;;;;    disclaimer in the documentation and/or other materials
;;;;    provided with the distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
;;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;; POSSIBILITY OF SUCH DAMAGE.

(cl:in-package #:sicl-clos)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class STANDARD-WRITER-METHOD.

(defclass standard-writer-method (standard-accessor-method)
  ())


(cl:in-package #:sicl-clos)

(defun ensure-class (name
		     &rest arguments
		     &key direct-superclasses
		     &allow-other-keys)
  (let* ((generated-name (gensym))
	 (environment (sicl-genv:global-environment))
	 (new-arguments (copy-list arguments))
	 (new-superclasses
	   (loop for superclass-name in (remove t direct-superclasses)
		 for class = (sicl-genv:find-class superclass-name environment)
		 collect (class-name class))))
    (loop while (remf new-arguments :direct-superclasses))
    (let ((class (apply #'closer-mop:ensure-class
			generated-name
			:direct-superclasses new-superclasses
			new-arguments)))
      (setf (sicl-genv:find-class name environment) class)
      class)))

Remove :METACLASS keyword argument before passing it to the host ENSURE-CLASS.

(cl:in-package #:sicl-clos)

(defun ensure-class (name
		     &rest arguments
		     &key direct-superclasses
		     &allow-other-keys)
  (let* ((generated-name (gensym))
	 (environment (sicl-genv:global-environment))
	 (new-arguments (copy-list arguments))
	 (new-superclasses
	   (loop for superclass-name in (remove t direct-superclasses)
		 for class = (sicl-genv:find-class superclass-name environment)
		 collect (class-name class))))
    (loop while (remf new-arguments :direct-superclasses))
    (loop while (remf new-arguments :metaclass))
    (let ((class (apply #'closer-mop:ensure-class
			generated-name
			:direct-superclasses new-superclasses
			new-arguments)))
      (setf (sicl-genv:find-class name environment) class)
      class)))


(defun test-parse ()
  (let* ((it.bese.yaclml.xmls::*strip-comments* nil)
	 (str (arnesi:read-string-from-file "/home/ACCELERATION/nathan/lisp/gainesville-green/templates/faq.tal"))
	 (form2 (cxml:parse str
			    (make-interner *uri-to-package*
					   (cxml:make-whitespace-normalizer
					    (cxml-xmls:make-xmls-builder
					     :include-namespace-uri t))))))
    form2))

(defun test-tran ()
  (let* ((form (test-parse))
	 (*expression-package* *package*)
	 (translated (transform-lxml-form form))
	 (lam `(lambda (-tal-environment-)
		 (declare (optimize (debug 3)))
		 (cxml:with-xml-output
		     (cxml:make-character-stream-sink *standard-output*
						      :indentation 2
						      :canonical nil)
		   ,translated)
		 nil)))
    lam))

(defun test-eval ()
  (let ((lam (test-tran)))
    (funcall (eval lam) nil)))

(defun test-tran2 ()
  (let ((pathname "/home/ACCELERATION/nathan/lisp/gainesville-green/templates/faq.tal"))
    (with-tal-compilation-unit pathname
      (compile-tal-string-to-lambda
       (read-tal-file-into-string pathname)))))

Put the test file in a reasonable package.

(in-package :ucw)
(defun test-parse ()
  (let* ((it.bese.yaclml.xmls::*strip-comments* nil)
	 (str (arnesi:read-string-from-file "/home/ACCELERATION/nathan/lisp/gainesville-green/templates/faq.tal"))
	 (form2 (cxml:parse str
			    (make-interner *uri-to-package*
					   (cxml:make-whitespace-normalizer
					    (cxml-xmls:make-xmls-builder
					     :include-namespace-uri t))))))
    form2))

(defun test-tran ()
  (let* ((form (test-parse))
	 (*expression-package* *package*)
	 (translated (transform-lxml-form form))
	 (lam `(lambda (-tal-environment-)
		 (declare (optimize (debug 3)))
		 (cxml:with-xml-output
		     (cxml:make-character-stream-sink *standard-output*
						      :indentation 2
						      :canonical nil)
		   ,translated)
		 nil)))
    lam))

(defun test-eval ()
  (let ((lam (test-tran)))
    (funcall (eval lam) nil)))

(defun test-tran2 ()
  (let ((pathname "/home/ACCELERATION/nathan/lisp/gainesville-green/templates/faq.tal"))
    (with-tal-compilation-unit pathname
      (compile-tal-string-to-lambda
       (read-tal-file-into-string pathname)))))


(cl:in-package #:clump-2-3-tree)

(defgeneric delete (leaf))

(defgeneric delete-child (parent child))

(defmethod delete ((leaf leaf))
  (delete-child (parent leaf) leaf))

Define new generic function REPLACE-AND-SHRINK.

(cl:in-package #:clump-2-3-tree)

(defgeneric delete (leaf))

(defgeneric delete-child (parent child))

(defgeneric replace-and-shrink (parent child))

(defmethod delete ((leaf leaf))
  (delete-child (parent leaf) leaf))


(asdf:defsystem :bld-ga
  :name "bld-ga"
  :author "Ben Diedrich <bldiedrich@gmail.com>"
  :license "MIT"
  :description "Library implementing geometric algebra. Define algebras based on dimension and inner product signature. Uses BLD-GEN system for generic arithmetic functions. Use BLD-GENSYM for symbolic scalars and coefficients. This implementation is meant to be slow and correct. For speed, see BLD-GAGEN, which adds optimized methods on geometric object types (e.g. vectors, bivectors, spinors) to BLD-GA."
  :depends-on ("bld-gen" "bld-utils" "bld-linalg" "alexandria")
  :components
  ((:file "package")
   (:file "metric" :depends-on ("package"))
   (:file "mv" :depends-on ("metric"))
   (:file "ga" :depends-on ("mv"))
   (:file "linear" :depends-on ("ga"))))

Include eg.lisp in ASD file to automaticall compile example algebras for convenience

(asdf:defsystem :bld-ga
  :name "bld-ga"
  :author "Ben Diedrich <bldiedrich@gmail.com>"
  :license "MIT"
  :description "Library implementing geometric algebra. Define algebras based on dimension and inner product signature. Uses BLD-GEN system for generic arithmetic functions. Use BLD-GENSYM for symbolic scalars and coefficients. This implementation is meant to be slow and correct. For speed, see BLD-GAGEN, which adds optimized methods on geometric object types (e.g. vectors, bivectors, spinors) to BLD-GA."
  :depends-on ("bld-gen" "bld-utils" "bld-linalg" "alexandria")
  :components
  ((:file "package")
   (:file "metric" :depends-on ("package"))
   (:file "mv" :depends-on ("metric"))
   (:file "ga" :depends-on ("mv"))
   (:file "linear" :depends-on ("ga"))
   (:file "eg" :depends-on ("linear"))))


(cl:in-package #:sicl-extrinsic-hir-compiler)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Main entry point.

(defun eval (form)
  (let* ((cleavir-generate-ast:*compiler* 'cl:eval)
	 (ast (cleavir-generate-ast:generate-ast form *environment*))
	 (hir (cleavir-ast-to-hir:compile-toplevel ast))
	 (lambda-expr (translate hir *environment*))
	 (fun (compile nil lambda-expr)))
    (funcall fun)))

(defmethod cleavir-env:eval (form environment1 (environment2 environment))
  (let* ((cleavir-generate-ast:*compiler* 'cl:eval)
	 (ast (cleavir-generate-ast:generate-ast form environment1))
	 (hir (cleavir-ast-to-hir:compile-toplevel ast)))
    (funcall
     (compile
      nil
      (translate hir environment2)))))

Make the two function have the same shape.

(cl:in-package #:sicl-extrinsic-hir-compiler)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Main entry point.

(defun eval (form)
  (let* ((cleavir-generate-ast:*compiler* 'cl:eval)
	 (ast (cleavir-generate-ast:generate-ast form *environment*))
	 (hir (cleavir-ast-to-hir:compile-toplevel ast))
	 (lambda-expr (translate hir *environment*))
	 (fun (compile nil lambda-expr)))
    (funcall fun)))

(defmethod cleavir-env:eval (form environment1 (environment2 environment))
  (let* ((cleavir-generate-ast:*compiler* 'cl:eval)
	 (ast (cleavir-generate-ast:generate-ast form environment1))
	 (hir (cleavir-ast-to-hir:compile-toplevel ast))
	 (lambda-expr (translate hir environment2))
	 (fun (compile nil lambda-expr)))
    (funcall fun)))


;;;;; TRE environment
;;;;; Copyright (c) 2005-2006,2008,2010 Sven Klose <pixel@copei.de>

(if (not (eq t *BUILTIN-MEMBER*))
  (progn
    (defun %member-r (elm lst)
      (if lst
          (if (equal elm (car lst))
			  lst
              (%member-r elm (cdr lst)))))

    (defun member (elm &rest lsts)
      (or (%member-r elm (car lsts))
          (if (cdr lsts)
              (apply #'member elm (cdr lsts)))))))

(define-test "MEMBER finds elements"
  ((if (member 's '(i) '(l i k e) '(l i s p))
	   t))
  t)

(define-test "MEMBER finds elements with user predicate"
  ((if (member "lisp" '("tre" "lisp") :test #'string=)
	  t))
  t)

(define-test "MEMBER detects foureign elements"
  ((member 'A '(l i s p)))
  nil)

(defun %member-if-r (pred lst)
  (if lst
      (if (funcall pred (car lst))
		  (car lst)
          (%member-if-r pred (cdr lst)))))

(defun member-if (pred &rest lsts)
  (or (%member-if-r pred (car lsts))
      (if (cdr lsts)
          (apply #'member-if pred (cdr lsts)))))

Return the cell, not the element.

;;;;; TRE environment
;;;;; Copyright (c) 2005-2006,2008,2010-2011 Sven Klose <pixel@copei.de>

(if (not (eq t *BUILTIN-MEMBER*))
  (progn
    (defun %member-r (elm lst)
      (if lst
          (if (equal elm (car lst))
			  lst
              (%member-r elm (cdr lst)))))

    (defun member (elm &rest lsts)
      (or (%member-r elm (car lsts))
          (if (cdr lsts)
              (apply #'member elm (cdr lsts)))))))

(define-test "MEMBER finds elements"
  ((if (member 's '(i) '(l i k e) '(l i s p))
	   t))
  t)

(define-test "MEMBER finds elements with user predicate"
  ((if (member "lisp" '("tre" "lisp") :test #'string=)
	  t))
  t)

(define-test "MEMBER detects foureign elements"
  ((member 'A '(l i s p)))
  nil)

(defun %member-if-r (pred lst)
  (if lst
      (if (funcall pred (car lst))
		  lst
          (%member-if-r pred (cdr lst)))))

(defun member-if (pred &rest lsts)
  (or (%member-if-r pred (car lsts))
      (if (cdr lsts)
          (apply #'member-if pred (cdr lsts)))))


;;;; fsocket.asd

(asdf:defsystem #:fsocket
  :description "Unix sockets extension for usocket."
  :author "Thayne McCombs <bytecurry.software@gmail.com>"
  :license "MIT"
  :depends-on (#:usocket)
  :serial t
  :components ((:file "package")
               (:file "fsocket")))

Add backends to asdf file.

;;;; fsocket.asd

(asdf:defsystem #:fsocket
  :description "Unix sockets extension for usocket."
  :author "Thayne McCombs <bytecurry.software@gmail.com>"
  :license "MIT"
  :depends-on (#:usocket)
  :components ((:file "package")
               (:file "fsocket" :depends-on ("package"))
               (:module backend :depends-on ("fsocket")
                :components (#+allegro (:file "allegro")
                             #+clozure (:file "clozure")
                             #+sbcl (:file "sbcl")))))


(cl:in-package #:common-lisp-user)

(asdf:defsystem :cleavir-ast-to-source
  :depends-on (:cleavir-ast :cleavir-primop)
  :serial t
  :components
  ((:file "packages")
   (:file "ast-to-source")
   (:file "fixnum")
   (:file "accessors")))

Define system in package ASDF-USER

(cl:in-package #:asdf-user)

(defsystem :cleavir-ast-to-source
  :depends-on (:cleavir-ast :cleavir-primop)
  :serial t
  :components
  ((:file "packages")
   (:file "ast-to-source")
   (:file "fixnum")
   (:file "accessors")))


(cl:in-package #:sicl-boot-phase1)

(defun ld (filename environment)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (sicl-extrinsic-environment:load-source-with-environments
   filename (compilation-environment environment) environment))

(defun fill-environment (environment)
  (sicl-genv:fmakunbound 'sicl-clos:ensure-generic-function-using-class
			 environment)
  (setf (sicl-genv:fdefinition 'make-instance environment)
	(let ((make-instance (sicl-genv:fdefinition
			      'make-instance
			      (compilation-environment environment))))
	  (lambda (&rest arguments)
	    (if (symbolp (first arguments))
		(apply make-instance
		       (sicl-genv:find-class
			(first arguments)
			(compilation-environment environment))
		       (rest arguments))
		(apply make-instance arguments)))))
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "temporary-ensure-class.lisp" environment)
  (ld "../../CLOS/standard-object-defclass.lisp" environment)
  (ld "../../CLOS/metaobject-defclass.lisp" environment)
  (ld "../../CLOS/specializer-defclass.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment))

Load file containing definition of variable *CLASS-UNIQUE-NUMBER*.

(cl:in-package #:sicl-boot-phase1)

(defun ld (filename environment)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (sicl-extrinsic-environment:load-source-with-environments
   filename (compilation-environment environment) environment))

(defun fill-environment (environment)
  (sicl-genv:fmakunbound 'sicl-clos:ensure-generic-function-using-class
			 environment)
  (setf (sicl-genv:fdefinition 'make-instance environment)
	(let ((make-instance (sicl-genv:fdefinition
			      'make-instance
			      (compilation-environment environment))))
	  (lambda (&rest arguments)
	    (if (symbolp (first arguments))
		(apply make-instance
		       (sicl-genv:find-class
			(first arguments)
			(compilation-environment environment))
		       (rest arguments))
		(apply make-instance arguments)))))
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "temporary-ensure-class.lisp" environment)
  (ld "../../CLOS/standard-object-defclass.lisp" environment)
  (ld "../../CLOS/metaobject-defclass.lisp" environment)
  (ld "../../CLOS/specializer-defclass.lisp" environment)
  (ld "../../CLOS/class-unique-number-defparameter.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment))


(in-package :lispkit)

(defparameter *jumps* (make-hash-table :test #'equal))

(defun defjump (place prefix url)
  (setf (gethash prefix place) url))

(defjump *jumps* "g" "http://google.com/search?q=~a")

(defun lookup-jump (s table)
  (gethash s table))

(defun extract-jump-str (s)
  (let ((splits (split-sequence #\Space s)))
    (list (first splits) (format nil "~{~a~^ ~}" (rest splits)))))

(defmacro multiple-value-destructuring-bind (lambda-list value-list &body body)
  (let ((ignore (gensym)))
    `(destructuring-bind (,@lambda-list &rest ,ignore)
         (multiple-value-list ,value-list)
       (declare (ignore ,ignore))
       ,@body)))

(defun apply-jumps (s browser)
  (multiple-value-destructuring-bind ((jump args)) (extract-jump-str s)
    (let ((jump? (lookup-jump jump *jumps*)))
      (when jump?
        (load-url (format nil jump? args) browser)
        t))))

Add github to the jump table

(in-package :lispkit)

(defparameter *jumps* (make-hash-table :test #'equal))

(defun defjump (place prefix url)
  (setf (gethash prefix place) url))

(defjump *jumps* "g" "http://google.com/search?q=~a")
(defjump *jumps* "gh" "https://github.com/search?&q=~a")

(defun lookup-jump (s table)
  (gethash s table))

(defun extract-jump-str (s)
  (let ((splits (split-sequence #\Space s)))
    (list (first splits) (format nil "~{~a~^ ~}" (rest splits)))))

(defmacro multiple-value-destructuring-bind (lambda-list value-list &body body)
  (let ((ignore (gensym)))
    `(destructuring-bind (,@lambda-list &rest ,ignore)
         (multiple-value-list ,value-list)
       (declare (ignore ,ignore))
       ,@body)))

(defun apply-jumps (s browser)
  (multiple-value-destructuring-bind ((jump args)) (extract-jump-str s)
    (let ((jump? (lookup-jump jump *jumps*)))
      (when jump?
        (load-url (format nil jump? args) browser)
        t))))


(cl:in-package #:clump-binary-tree)

(defgeneric rotate-left (tree))

(defgeneric rotate-right (tree))

(defmethod rotate-left ((tree node))
  (when (null (right tree))
    (error 'right-subtree-must-be-non-nil :tree tree))

Add default method on ROTATE-LEFT.

(cl:in-package #:clump-binary-tree)

(defgeneric rotate-left (tree))

(defgeneric rotate-right (tree))

(defmethod rotate-left (tree)
  (error 'invalid-binary-tree :tree tree))

(defmethod rotate-left ((tree node))
  (when (null (right tree))
    (error 'right-subtree-must-be-non-nil :tree tree))


#|
 This file is a part of LASS
 (c) 2014 TymoonNET/NexT http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(defpackage #:binary-lass
  (:nicknames #:org.tymoonnext.lass.bianry)
  (:use #:cl)
  (:export
   #:main
   #:cmd-wrapper))
(in-package #:binary-lass)

(defun main (&optional in out (pretty "false"))
  (if in
      (let* ((in (uiop:parse-native-namestring in))
             (out (or (when out (uiop:parse-native-namestring out))
                      (merge-pathnames (make-pathname :type "css") in)))
             (pretty (or (string-equal pretty "true")
                         (string-equal pretty "T"))))
        (lass:generate in :out out :pretty pretty)
        (uiop:native-namestring out))
      (format T "Usage: lass LASS-FILE [ OUTPUT-CSS-FILE [ PRETTY-PRINTING ] ] ~%~%LASS v~a ~a~%"
              (asdf:component-version (asdf:find-system :LASS))
              (asdf:system-homepage (asdf:find-system :LASS)))))

(defun cmd-wrapper (args)
  (apply #'main (cdr args)))

Fix for other impls (specifically CCL)

#|
 This file is a part of LASS
 (c) 2014 TymoonNET/NexT http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(defpackage #:binary-lass
  (:nicknames #:org.tymoonnext.lass.bianry)
  (:use #:cl)
  (:export
   #:main
   #:cmd-wrapper))
(in-package #:binary-lass)

(defun main (&optional in out (pretty "false"))
  (if in
      (let* ((in (uiop:parse-native-namestring in))
             (out (or (when out (uiop:parse-native-namestring out))
                      (merge-pathnames (make-pathname :type "css") in)))
             (pretty (or (string-equal pretty "true")
                         (string-equal pretty "T"))))
        (lass:generate in :out out :pretty pretty)
        (uiop:native-namestring out))
      (format T "Usage: lass LASS-FILE [ OUTPUT-CSS-FILE [ PRETTY-PRINTING ] ] ~%~%LASS v~a ~a~%"
              (asdf:component-version (asdf:find-system :LASS))
              (asdf:system-homepage (asdf:find-system :LASS)))))

(defun cmd-wrapper (&optional args)
  (let ((args (or args
                  #+SBCL *posix-argv*
                  #+LISPWORKS system:*line-arguments-list*
                  #+CMU extensions:*command-line-words*
                  #+CCL ccl:*command-line-argument-list*
                  NIL)))
    (apply #'main (cdr args))))


(cl:in-package #:sicl-extrinsic-file-compiler)

(defmethod cleavir-hir-transformations:introduce-immediate
    (constant
     (implementation sicl-target-sicl:sicl)
     (processor sicl-x86-64:x86-64)
     os)
  (let ((value (cleavir-ir:value constant)))
    (cond ((and (typep value 'integer)
		(<= #.(- (expt 2 30)) value #.(1- (expt 2 30))))
	   (cleavir-ir:make-immediate-input (* 2 value)))
	  ((typep value 'character)
	   ;; FIXME: Currently, we depend on the host having the same
	   ;; character encoding as the target.
	   (cleavir-ir:make-immediate-input (+ #b11 (* 4 (char-code value)))))
	  (t
	   constant))))

Use processor class from Cleavir.

(cl:in-package #:sicl-extrinsic-file-compiler)

(defmethod cleavir-hir-transformations:introduce-immediate
    (constant
     (implementation sicl-target-sicl:sicl)
     (processor cleavir-processor-x86-64:x86-64)
     os)
  (let ((value (cleavir-ir:value constant)))
    (cond ((and (typep value 'integer)
		(<= #.(- (expt 2 30)) value #.(1- (expt 2 30))))
	   (cleavir-ir:make-immediate-input (* 2 value)))
	  ((typep value 'character)
	   ;; FIXME: Currently, we depend on the host having the same
	   ;; character encoding as the target.
	   (cleavir-ir:make-immediate-input (+ #b11 (* 4 (char-code value)))))
	  (t
	   constant))))


(cl:in-package #:sicl-boot-phase1)

(defun ld (filename environment)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (sicl-extrinsic-environment:load-source-with-environments
   filename (compilation-environment environment) environment))

(defun fill-environment (environment)
  (setf (sicl-genv:find-class 'standard-class
			      (compilation-environment environment))
	(find-class 'temporary-standard-class))
  (sicl-genv:fmakunbound 'sicl-clos:ensure-generic-function-using-class
			 environment)
  (setf (sicl-genv:fdefinition 'make-instance environment)
	(let ((make-instance (sicl-genv:fdefinition
			      'make-instance
			      (compilation-environment environment))))
	  (lambda (&rest arguments)
	    (if (symbolp (first arguments))
		(apply make-instance
		       (sicl-genv:find-class
			(first arguments)
			(compilation-environment environment))
		       (rest arguments))
		(apply make-instance arguments)))))
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "temporary-ensure-class.lisp" environment)
  (ld "../../CLOS/standard-object-defclass.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment))

Load a file containing the definition of the class METAOBJECT.

(cl:in-package #:sicl-boot-phase1)

(defun ld (filename environment)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (sicl-extrinsic-environment:load-source-with-environments
   filename (compilation-environment environment) environment))

(defun fill-environment (environment)
  (setf (sicl-genv:find-class 'standard-class
			      (compilation-environment environment))
	(find-class 'temporary-standard-class))
  (sicl-genv:fmakunbound 'sicl-clos:ensure-generic-function-using-class
			 environment)
  (setf (sicl-genv:fdefinition 'make-instance environment)
	(let ((make-instance (sicl-genv:fdefinition
			      'make-instance
			      (compilation-environment environment))))
	  (lambda (&rest arguments)
	    (if (symbolp (first arguments))
		(apply make-instance
		       (sicl-genv:find-class
			(first arguments)
			(compilation-environment environment))
		       (rest arguments))
		(apply make-instance arguments)))))
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "temporary-ensure-class.lisp" environment)
  (ld "../../CLOS/standard-object-defclass.lisp" environment)
  (ld "../../CLOS/metaobject-defclass.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment))


;;;;; TRE transpiler environment
;;;;; Copyright (c) 2008-2009,2011 Sven Klose <pixel@copei.de>

(defun eql (x y)
  (unless x			; Convert falsity to 'null'.
	(setq x nil))
  (unless y
	(setq y nil))
  (or (%%%eq x y)
	  (= x y)))

Return NIL if numbers don't have the same type.

;;;;; tré - Copyright (c) 2008-2009,2011 Sven Klose <pixel@copei.de>

(defun eql (x y)
  (unless x			; Convert falsity to 'null'.
	(setq x nil))
  (unless y
	(setq y nil))
  (or (%%%eq x y)
      (? (or (number? x) (number? y))
         (?
           (and (integer? x) (integer? y))
	         (integer= x y)
           (and (character? x) (character? y))
	         (character= x y))
	    (= x y))))


(cl:in-package #:sicl-clos)

(defmethod reader-method-class
    ((class regular-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'reader-method-class-default class direct-slot initargs))

(defmethod writer-method-class
    ((class regular-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'writer-method-class-default class direct-slot initargs))

Add temporary methods for BUILT-IN-CLASS.

(cl:in-package #:sicl-clos)

(defmethod reader-method-class
    ((class regular-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'reader-method-class-default class direct-slot initargs))

(defmethod writer-method-class
    ((class regular-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'writer-method-class-default class direct-slot initargs))

;;; These methods should be removed when the system is in production.

(defmethod reader-method-class
    ((class built-in-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'reader-method-class-default class direct-slot initargs))

(defmethod writer-method-class
    ((class built-in-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'writer-method-class-default class direct-slot initargs))


(cl:in-package #:asdf-user)

(defsystem :clump-binary-tree
  :depends-on (:acclimation)
  :serial t
  :components
  ((:file "packages")
   (:file "binary-tree")
   (:file "conditions")
   (:file "replace-child")
   (:file "rotation")
   (:file "recursive-traversal")
   (:file "iterative-traversal")
   (:file "docstrings-english")
   (:file "condition-reporters-english")))

Add moved and renamed component to system definition.

(cl:in-package #:asdf-user)

(defsystem :clump-binary-tree
  :depends-on (:acclimation)
  :serial t
  :components
  ((:file "packages")
   (:file "binary-tree")
   (:file "conditions")
   (:file "replace-child")
   (:file "rotation")
   (:file "recursive-traversal")
   (:file "iterative-traversal")
   (:file "splay")
   (:file "docstrings-english")
   (:file "condition-reporters-english")))


(cl:in-package #:asdf-user)

(defsystem :clobber
  :serial t
  :components
  ((:file "packages")
   (:file "clobber")
   (:file "demo")
   (:file "demo2")))

Add metadata required by Quicklisp.

(cl:in-package #:asdf-user)

(defsystem :clobber
  :description "Library for transaction-oriented data bases."
  :author "Robert Strandh <robert.strandh@gmail.com>"
  :license "FreeBSD, see file LICENSE.text"
  :serial t
  :components
  ((:file "packages")
   (:file "clobber")
   (:file "demo")
   (:file "demo2")))


#|
 This file is a part of Colleen
 (c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:cl-user)
(asdf:defsystem colleen
  :version "2.2.0"
  :license "Artistic"
  :author "Nicolas Hafner <shinmera@tymoon.eu>"
  :maintainer "Nicolas Hafner <shinmera@tymoon.eu>"
  :homepage "http://github.com/Shinmera/colleen"
  :description "IRC bot with a modular framework."
  :serial T
  :components ((:file "package")
               (:file "globals")
               (:file "conditions")
               (:file "irc-codes")
               (:file "config")
               (:file "toolkit")
               (:file "module")
               (:file "module-storage")
               (:file "event")
               (:file "event-priority")
               (:file "event-handler")
               (:file "client")
               (:file "command-handler")
               (:file "time-handler")
               (:file "irc-commands")
               (:file "irc-events")
               (:file "asdf-extra")
               (:file "launcher")
               (:module "modules"
                :components ((:file "system-definitions")
                             (:file "core"))))
  :depends-on (:bordeaux-threads
               :universal-config
               :verbose
               :usocket
               :flexi-streams
               :uuid
               :cl-ppcre
               :trivial-arguments))

Remove in-package from ASD file.

#|
 This file is a part of Colleen
 (c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(asdf:defsystem colleen
  :version "2.2.0"
  :license "Artistic"
  :author "Nicolas Hafner <shinmera@tymoon.eu>"
  :maintainer "Nicolas Hafner <shinmera@tymoon.eu>"
  :homepage "http://github.com/Shinmera/colleen"
  :description "IRC bot with a modular framework."
  :serial T
  :components ((:file "package")
               (:file "globals")
               (:file "conditions")
               (:file "irc-codes")
               (:file "config")
               (:file "toolkit")
               (:file "module")
               (:file "module-storage")
               (:file "event")
               (:file "event-priority")
               (:file "event-handler")
               (:file "client")
               (:file "command-handler")
               (:file "time-handler")
               (:file "irc-commands")
               (:file "irc-events")
               (:file "asdf-extra")
               (:file "launcher")
               (:module "modules"
                :components ((:file "system-definitions")
                             (:file "core"))))
  :depends-on (:bordeaux-threads
               :universal-config
               :verbose
               :usocket
               :flexi-streams
               :uuid
               :cl-ppcre
               :trivial-arguments))


;;;;; tré – Copyright (c) 2008–2013 Sven Michael Klose <pixel@copei.de>

(defun %compile-environment-configure-transpiler (tr funs)
  (= (transpiler-dot-expand? (copy-transpiler tr)) nil)
  (transpiler-add-wanted-functions tr (| funs (+ *universe-functions* *macros*)))
  tr)

(defun compile-c-environment (&optional (funs nil))
  (let tr (%compile-environment-configure-transpiler *c-transpiler* funs)
    (let code (compile-files nil :target 'c :transpiler tr)
      (with-open-file out (open "interpreter/_compiled-env.c" :direction 'output)
	    (princ code out))))
  nil)

(defun compile-bytecode-environment (&optional (funs nil))
  (let tr (%compile-environment-configure-transpiler *bc-transpiler* funs)
    (compile-files nil :target 'bytecode :transpiler tr))
  nil)

(defun compile-c-compiler ()
  (compile-c-environment '(c-transpile)))

(defun compile-bytecode-compiler ()
  (compile-bytecode-environment '(bc-transpile)))

Return bytecode instead of NIL.

;;;;; tré – Copyright (c) 2008–2013 Sven Michael Klose <pixel@copei.de>

(defun %compile-environment-configure-transpiler (tr funs)
  (= (transpiler-dot-expand? (copy-transpiler tr)) nil)
  (transpiler-add-wanted-functions tr (| funs (+ *universe-functions* *macros*)))
  tr)

(defun compile-c-environment (&optional (funs nil))
  (let tr (%compile-environment-configure-transpiler *c-transpiler* funs)
    (let code (compile-files nil :target 'c :transpiler tr)
      (with-open-file out (open "interpreter/_compiled-env.c" :direction 'output)
	    (princ code out))))
  nil)

(defun compile-bytecode-environment (&optional (funs nil))
  (let tr (%compile-environment-configure-transpiler *bc-transpiler* funs)
    (compile-files nil :target 'bytecode :transpiler tr)))

(defun compile-c-compiler ()
  (compile-c-environment '(c-transpile)))

(defun compile-bytecode-compiler ()
  (compile-bytecode-environment '(bc-transpile)))


;;;; ----------------------------------------------------------------------
;;;;     Title: X11 standard keysym interpretation rules
;;;;   Created: 2016-01-25
;;;;    Author: Robert Strandh <robert.strandh@gmail.com>
;;;;   License: LGPL (See file COPYING for details).
;;;; ----------------------------------------------------------------------
;;;;  (c) copyright 2016 by Robert Strandh

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Library General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Library General Public
;;;; License along with this library; if not, write to the
;;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;;; Boston, MA  02111-1307  USA.

(cl:in-package #:clim-clx)

Define a class to hold interpretation information.

;;;; ----------------------------------------------------------------------
;;;;     Title: X11 standard keysym interpretation rules
;;;;   Created: 2016-01-25
;;;;    Author: Robert Strandh <robert.strandh@gmail.com>
;;;;   License: LGPL (See file COPYING for details).
;;;; ----------------------------------------------------------------------
;;;;  (c) copyright 2016 by Robert Strandh

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Library General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Library General Public
;;;; License along with this library; if not, write to the
;;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;;; Boston, MA  02111-1307  USA.

(cl:in-package #:clim-clx)

(defclass keysym-interpretation ()
  (;; This slot contains a mask to be applied to an X11 modifier mask
   ;; to determine whether the "mode switch" modifier is in effect.
   (%mode-switch-mask :initarg :mode-swith-mask
		      :initform #b00000000
		      :accessor mode-switch-mask)))


(in-package #:saluto)

(defvar *providers* '()
  "Variable, containing providers objects
Should be replaced when mounting module")

(defun parse-provider (provider-name)
  (or (find provider-name (print *providers*) :key #'name :test #'string=)
      (error "SALUTO: No such provider ~A" provider-name)))

(restas:define-route login-with ("goto/:provider/" :method :get)
;  (:sift-variables (provider #'parse-provider))
  (:additional-variables (redirect-uri (hunchentoot:parameter "redirect")))
  ;; This REDIRECT-URI means just target page after successful login
(let ((provider (parse-provider provider)))
  (if (not (session))
      (progn
        (start-session)
        (redirect
         (make-goto-path provider
                         (session)
                         (or redirect-uri *main*)))
      (redirect redirect-uri)))))

(restas:define-route receiver-route ("receiver/:provider/*states"
                                     :method :get)
;  (:sift-variables (provider #'parse-provider))
  (:additional-variables
   (state (hunchentoot:parameter "state"))
   (code (hunchentoot:parameter "code"))
   (error? (hunchentoot:parameter "error")))
(let ((provider (parse-provider provider)))
  (receive provider
           (or state (car states))  ;; It depends on provider, whether
                                    ;; it wants redirect URL to be
                                    ;; stable or uniq
           code error?)))

(restas:define-route logout-route ("logout" :method :get)
  (logout)
  (redirect *main*))

Synchronize with latest (warning!) RESTAS

(in-package #:saluto)

(defvar *providers* '()
  "Variable, containing providers objects
Should be replaced when mounting module")

(defun parse-provider (provider-name)
  (or (find provider-name *providers* :key #'name :test #'string=)
      (error "SALUTO: No such provider ~A" provider-name)))

(restas:define-route login-with ("goto/:provider/" :method :get)
  (:sift-variables (provider #'parse-provider))
  (:additional-variables (redirect-uri (hunchentoot:parameter "redirect")))
  ;; This REDIRECT-URI means just target page after successful login
  (if (not (session))
      (progn
        (start-session)
        (redirect
         (make-goto-path provider
                         (session)
                         (or redirect-uri *main*)))
      (redirect redirect-uri))))

(restas:define-route receiver-route ("receiver/:provider/*states"
                                     :method :get)
  (:sift-variables (provider #'parse-provider))
  (:additional-variables
   (state (hunchentoot:parameter "state"))
   (code (hunchentoot:parameter "code"))
   (error? (hunchentoot:parameter "error")))
  (receive provider
           (or state (car states))  ;; It depends on provider, whether
                                    ;; it wants redirect URL to be
                                    ;; stable or uniq
           code error?))

(restas:define-route logout-route ("logout" :method :get)
  (logout)
  (redirect *main*))


(cl:in-package #:sicl-clos)

(defmacro defmethod (&environment env function-name &rest rest)
  (multiple-value-bind
	(qualifiers lambda-list specializers declarations documentation forms)
      (parse-defmethod rest)
    (let ((generic-function-var (gensym)))
      `(let ((,generic-function-var
	       (ensure-generic-function ',function-name :environment ,env)))
	 (ensure-method
	  ,generic-function-var
	  ,env
	  :lambda-list ',lambda-list
	  :qualifiers ',qualifiers
	  :specializers ,(canonicalize-specializers specializers)
	  :documentation ,documentation
	  :function ,(make-method-lambda
		      ;; FIXME: do this better.
		      (class-prototype (find-class 'standard-generic-function))
		      (class-prototype (find-class 'standard-method))
		      `(lambda ,lambda-list
			 ,@declarations
			 ,@forms)
		      nil))))))

Use function SICL-ENVIRONMENT:FIND-CLASS to look up class prototypes.

(cl:in-package #:sicl-clos)

(defmacro defmethod (&environment env function-name &rest rest)
  (multiple-value-bind
	(qualifiers lambda-list specializers declarations documentation forms)
      (parse-defmethod rest)
    (let ((generic-function-var (gensym)))
      `(let ((,generic-function-var
	       (ensure-generic-function ',function-name :environment ,env)))
	 (ensure-method
	  ,generic-function-var
	  ,env
	  :lambda-list ',lambda-list
	  :qualifiers ',qualifiers
	  :specializers ,(canonicalize-specializers specializers)
	  :documentation ,documentation
	  :function
	  ,(make-method-lambda
	    ;; FIXME: do this better.
	    (class-prototype
	     (sicl-environment:find-class 'standard-generic-function ,env))
	    (class-prototype
	     (sicl-environment:find-class 'standard-method ,env))
	    `(lambda ,lambda-list
	       ,@declarations
	       ,@forms)
	    nil))))))


(cl:in-package :sicl-arithmetic)

(defun + (&rest args)
  (cond ((null args) 0)
	;; FIXME: check that we have a number
	((null (cdr args)) (car args))
	(t (apply #'+ (binary-add (car args) (cadr args)) (cddr args)))))

(defun - (x &rest args)
  (cond ((null args) (negate x))
	((null (cdr args)) (binary-sub x (car args)))
	(t (apply #'- (binary-sub x (car args)) (cdr args)))))

(defun * (&rest args)
  (cond ((null args) 1)
	;; FIXME: check that we have a number
	((null (cdr args)) (car args))
	(t (apply #'* (binary-mul (car args) (cadr args)) (cddr args)))))

(defun / (x &rest args)
  (cond ((null args) (invert x))
	((null (cdr args)) (binary-div x (car args)))
	(t (apply #'/ (binary-div x (car args)) (cdr args)))))

Remove useless blank lines at end of file.


;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
(in-package :cl-user)

(defpackage "CLIM-LISTENER"
  (:use "CLIM" "CLIM-LISP")
  (:export #:run-listener #:dev-commands))

(in-package :clim-listener)

(eval-when (:load-toplevel)
;  (format t "~&~%!@#%^!@#!@ ... ~A~%~%" *load-truename*)
  (defparameter *icon-path* (merge-pathnames #P"icons/" *load-truename*)))

Patch from Martin Raspaud to make the Listener compile when fasl directory != source directory.

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
(in-package :cl-user)

(defpackage "CLIM-LISTENER"
  (:use "CLIM" "CLIM-LISP")
  (:export #:run-listener #:dev-commands))

(in-package :clim-listener)

(eval-when (:load-toplevel)
;  (format t "~&~%!@#%^!@#!@ ... ~A~%~%" *load-truename*)
  (defparameter *icon-path* (merge-pathnames
                             #P"icons/"
                             (load-time-value (or #.*compile-file-pathname* *load-pathname*)))))


(format t "loading xml-rpc...~%")

#+allegro
(progn
  (in-package :common-lisp-user)

  (defvar *xml-rpc-server-id*)
  (require :xml-rpc)
  (defun start-xml-rpc-server (port)
    (let ((start-args (list :port port)))
      (progn
	(setq *xml-rpc-server-id*
	      (net.xml-rpc:make-xml-rpc-server
	       :start start-args :enable t :introspect t))
	(net.xml-rpc:export-standard-xml-rpc-methods *xml-rpc-server-id*))))
)

#+openmcl
(progn
  (defpackage :s-xml)
  (defpackage :s-xml-rpc)

  (in-package :common-lisp-user)

  (defun start-xml-rpc-server (port)
    (s-xml-rpc:start-xml-rpc-server :port port)
    (format t ";;; XML-RPC server listening at port ~A~%" port)
    )
)

Refactor to avoid package undefined error.

(format t "loading xml-rpc...~%")

#+allegro
(require :xml-rpc)

#+allegro
(progn
  (in-package :common-lisp-user)

  (defvar *xml-rpc-server-id*)
  (defun start-xml-rpc-server (port)
    (let ((start-args (list :port port)))
      (progn
	(setq *xml-rpc-server-id*
	      (net.xml-rpc:make-xml-rpc-server
	       :start start-args :enable t :introspect t))
	(net.xml-rpc:export-standard-xml-rpc-methods *xml-rpc-server-id*))))
)

#+openmcl
(progn
  (defpackage :s-xml)
  (defpackage :s-xml-rpc)

  (in-package :common-lisp-user)

  (defun start-xml-rpc-server (port)
    (s-xml-rpc:start-xml-rpc-server :port port)
    (format t ";;; XML-RPC server listening at port ~A~%" port)
    )
)


(defsystem :swap-bytes
  :serial t
  :components ((:file "package")
               #+sbcl (:file "sbcl")
               (:file "portable")))

Add missing dependency on Trivial-features

(defsystem :swap-bytes
  :depends-on (:trivial-features)
  :serial t
  :components ((:file "package")
               #+sbcl (:file "sbcl")
               (:file "portable")))


(cl:in-package #:sicl-clos)

(defun parse-defmethod (args)
  (let ((name (pop args))
	(qualifiers (loop while (and (consp args) (not (listp (car args))))
			  collect (pop args)))
	(lambda-list (pop args)))
    ;; FIXME: handle declarations and documentation
    (let* ((parsed-lambda-list (parse-specialized-lambda-list lambda-list))
	   (required (required parsed-lambda-list)))
      (values name
	      qualifiers
	      (append (mapcar #'car required)
		      (subseq lambda-list (length required)))
	      (mapcar #'cadr required)
	      args))))

(defun canonicalize-specializers (specializers)
  ;; FIXME: handle eql specializers.
  `(mapcar #'find-class ',specializers))

Handle canonicalization of EQL specializers.

(cl:in-package #:sicl-clos)

(defun parse-defmethod (args)
  (let ((name (pop args))
	(qualifiers (loop while (and (consp args) (not (listp (car args))))
			  collect (pop args)))
	(lambda-list (pop args)))
    ;; FIXME: handle declarations and documentation
    (let* ((parsed-lambda-list (parse-specialized-lambda-list lambda-list))
	   (required (required parsed-lambda-list)))
      (values name
	      qualifiers
	      (append (mapcar #'car required)
		      (subseq lambda-list (length required)))
	      (mapcar #'cadr required)
	      args))))

(defun canonicalize-specializer (specializer)
  (cond ((symbolp specializer)
	 `',specializer)
	((and (consp specializer)
	      (consp (cdr specializer))
	      (null (cddr specializer)))
	 `(make-instance 'eql-specializer :object ,(cadr specializer)))
	(t
	 (error "malformed specializer: ~s" specializer))))

(defun canonicalize-specializers (specializers)
  `(list ,@(mapcar #'canonicalize-specializer specializers)))


(cl:in-package #:common-lisp-user)

(asdf:defsystem :sicl-compiler-test-utilities
  :components
  ((:file "packages")
   (:file "test-utilities" :depends-on ("packages"))))

Make it depend on sicl-compiler-utilities.

(cl:in-package #:common-lisp-user)

(asdf:defsystem :sicl-compiler-test-utilities
  :depends-on (:sicl-compiler-utilities)
  :components
  ((:file "packages")
   (:file "test-utilities" :depends-on ("packages"))))


;;;; -*- Mode: Lisp; -*-

(defsystem "hello"
  :description "Example Bazel Hello World application"
  :class program-system
  :entry-point "hello:main"
  :depends-on (:alexandria)
  :components ((:file "hello")))

(defsystem "hello/chello"
  :description "Example Bazel Hello World application, using C"
  :class program-system
  :entry-point "chello:main"
  :defsystem-depends-on (:cffi-toolchain)
  :depends-on (:cffi)
  :serial t
  :components
  ((:c-file "chello_lib")
   (:file "chello")))

Make cffi-toolchain a runtime dependency, too.

;;;; -*- Mode: Lisp; -*-

(defsystem "hello"
  :description "Example Bazel Hello World application"
  :class program-system
  :entry-point "hello:main"
  :depends-on (:alexandria)
  :components ((:file "hello")))

(defsystem "hello/chello"
  :description "Example Bazel Hello World application, using C"
  :class program-system
  :entry-point "chello:main"
  :defsystem-depends-on (:cffi-toolchain)
  :depends-on (:cffi-toolchain)
  :serial t
  :components
  ((:c-file "chello_lib")
   (:file "chello")))


;;;; Readers for reading more easier formats.
;;; Nov. 25th 2012, chiku
;;; This is the last step.
(in-package :chiku.genscreenrc)

(defun |[-reader| (strm c)
  (declare (ignore c))
  (destructuring-bind (key &rest cmdseq)
    (read-delimited-list #\] strm t)
    (list key (multiple-value-bind (result top)
                (group-headed "!" cmdseq :mark-discard? t :key #'symbol-name :test #'string=)
                (cons top result)))))

(set-macro-character #\[ #'|[-reader| nil)

(set-macro-character #\] (get-macro-character #\)))

(defun |{-reader| (strm c)
  (declare (ignore c))
  (destructuring-bind (start dst &rest key-cmdseqs)
    (read-delimited-list #\} strm t)
    `(multiple-keybinds t ,start ,dst
       ,@key-cmdseqs)))

(set-macro-character #\{ #'|{-reader| nil)

(set-macro-character #\} (get-macro-character #\) nil))

Revert "[Bugfix] Symbols are too delicate to use at boundaries."

;;;; Readers for reading more easier formats.
;;; Nov. 25th 2012, chiku
;;; This is the last step.
(in-package :chiku.genscreenrc)

(defun |[-reader| (strm c)
  (declare (ignore c))
  (destructuring-bind (key &rest cmdseq)
    (read-delimited-list #\] strm t)
    (list key (multiple-value-bind (result top)
                (group-headed '! cmdseq :mark-discard? t)
                (cons top result)))))

(set-macro-character #\[ #'|[-reader| nil)

(set-macro-character #\] (get-macro-character #\)))

(defun |{-reader| (strm c)
  (declare (ignore c))
  (destructuring-bind (start dst &rest key-cmdseqs)
    (read-delimited-list #\} strm t)
    `(multiple-keybinds t ,start ,dst
       ,@key-cmdseqs)))

(set-macro-character #\{ #'|{-reader| nil)

(set-macro-character #\} (get-macro-character #\) nil))


(cl:in-package #:sicl-boot)

(defmethod print-object ((class standard-class) stream)
  (format stream
	  "#<Ersatz standard class ~s>"
	  (sicl-clos:class-name class)))

(defmethod print-object ((class sicl-clos:built-in-class) stream)
  (format stream
	  "#<Ersatz built-in class ~s>"
	  (sicl-clos:class-name class)))

Add method on PRINT-OBJECT specialized to STANDARD-GENERIC-FUNCTION.

(cl:in-package #:sicl-boot)

(defmethod print-object ((class standard-class) stream)
  (format stream
	  "#<Ersatz standard class ~s>"
	  (sicl-clos:class-name class)))

(defmethod print-object ((class sicl-clos:built-in-class) stream)
  (format stream
	  "#<Ersatz built-in class ~s>"
	  (sicl-clos:class-name class)))

(defmethod print-object ((function standard-generic-function) stream)
  (format stream
	  "#<Ersatz standard generic function ~s>"
	  (sicl-clos:generic-function-name function)))


(cl:in-package #:asdf-user)

(defsystem :cleavir-reaching-definitions
  :depends-on (:cleavir-utilities)
  :components
  ((:file "packages")
   (:file "reaching-definitions" :depends-on ("packages"))))

Simplify system definition by the use of option :SERIAL T.

(cl:in-package #:asdf-user)

(defsystem :cleavir-reaching-definitions
  :depends-on (:cleavir-utilities)
  :serial t
  :components
  ((:file "packages")
   (:file "reaching-definitions")))


(defun make-cd (title artist rating ripped)
  (list :title title :artist artist :rating rating :ripped ripped))

(defvar *db* nil)

(defun add-cd (cd)
  (push cd *db*))

(defun dump-db ()
  (dolist (cd *db*)
    (format t "~{~a:~10t~a~%~}~%" cd)))

(defun dump-db-short ()
  (format t "~{~{~a:~10t~a~%~}~%~}" *db*))

(defun prompt-read (prompt)
  (format *query-io* "~a: " prompt)
  (force-output *query-io*)
  (read-line *query-io*))

(defun prompt-for-cd ()
  (make-cd
   (prompt-read "Title")
   (prompt-read "Artist")
   (or (parse-integer (prompt-read "Rating") :junk-allowed t) 0)
   (y-or-n-p "Ripped [y/n]")))

Join all functions into one

(defun make-cd (title artist rating ripped)
  (list :title title :artist artist :rating rating :ripped ripped))

(defvar *db* nil)

(defun add-cd (cd)
  (push cd *db*))

(defun dump-db ()
  (dolist (cd *db*)
    (format t "~{~a:~10t~a~%~}~%" cd)))

(defun dump-db-short ()
  (format t "~{~{~a:~10t~a~%~}~%~}" *db*))

(defun prompt-read (prompt)
  (format *query-io* "~a: " prompt)
  (force-output *query-io*)
  (read-line *query-io*))

(defun prompt-for-cd ()
  (make-cd
   (prompt-read "Title")
   (prompt-read "Artist")
   (or (parse-integer (prompt-read "Rating") :junk-allowed t) 0)
   (y-or-n-p "Ripped [y/n]")))

(defun add-cds ()
  (loop (add-cd (prompt-for-cd))
     (if (not (y-or-n-p "Another? [y/n]: ")) (return))))


;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

(def-suite :it.bese.arnesi.numbers :in :it.bese.arnesi)

(in-suite :it.bese.arnesi.numbers)

(test mulf
  (let ((a 0))
    (is (= 0 (mulf a 10)))
    (is (= 0 a)))

  (let ((a 1))
    (is (= 4 (mulf a 4)))
    (is (= 1 (mulf a (/ 4))))
    (is (= 1 a))))

(test minf
  (let ((a 10))
    (is (= 5 (minf a 5)))
    (is (= 5 a)))

  (let ((a 0))
    (is (= 0 (minf a 10)))
    (is (= 0 a))))

(test parse-float
  (is (= 0 (parse-float "0")))
  (is (= -1 (parse-float "-1")))
  (is (= 1 (parse-float "1")))

  (dolist (type '(short-float single-float double-float long-float))
    (dotimes (i 1000)
      (let* ((*print-radix* 10)
             (number (random  (1+ (coerce i type))))
             (string (princ-to-string number))
             (value (parse-float string :type type)))
        (unless (= number value)
          (fail "~S parse-float'd to ~S (not ~S)." string value number))))))

Use FiveAM's new random testing for the parse-float test

;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

(def-suite :it.bese.arnesi.numbers :in :it.bese.arnesi)

(in-suite :it.bese.arnesi.numbers)

(test mulf
  (let ((a 0))
    (is (= 0 (mulf a 10)))
    (is (= 0 a)))

  (let ((a 1))
    (is (= 4 (mulf a 4)))
    (is (= 1 (mulf a (/ 4))))
    (is (= 1 a))))

(test minf
  (let ((a 10))
    (is (= 5 (minf a 5)))
    (is (= 5 a)))

  (let ((a 0))
    (is (= 0 (minf a 10)))
    (is (= 0 a))))

(test parse-float
  (is (= 0 (parse-float "0")))
  (is (= -1 (parse-float "-1")))
  (is (= 1 (parse-float "1")))

  (dolist (type '(short-float single-float double-float long-float))
    (for-all ((float (gen-float :type type :bound 1000)))
      (let* ((*print-base* 10)
             (*print-radix* nil))
        (is (= float (parse-float (princ-to-string float) :type type)))))))


(cl:in-package #:common-lisp-user)

(asdf:defsystem :sicl-compiler
  :depends-on (:cleavir-code-utilities
	       :sicl-global-environment
	       :sicl-reader-simple
	       :sicl-generate-ast
	       :sicl-type
	       :cleavir-ast
	       :cleavir-primop)
  :serial t
  :components
  ((:file "packages")
   (:file "compile-file")))

Define ASDF system in package ASDF-USER.

(cl:in-package #:asdf-user)

(defsystem :sicl-compiler
  :depends-on (:cleavir-code-utilities
	       :sicl-global-environment
	       :sicl-reader-simple
	       :sicl-generate-ast
	       :sicl-type
	       :cleavir-ast
	       :cleavir-primop)
  :serial t
  :components
  ((:file "packages")
   (:file "compile-file")))


;; vector-operations.lisp
;;
;; Copyright (c) 2012 Matt Novenstern <fisxoj@gmail.com>
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 3 of
;; the GNU Affero General Public License as published by
;; the Free Software Foundation.
;;
;; This code is distributed in the hope that it will be useful,
;; but without any warranty; without even the implied warranty of
;; merchantability or fitness for a particular purpose. See the GNU
;; Affero General Public License for more details.
;;
;; Version 3 of the GNU Affero General Public License is in the file
;; LICENSE that was distributed with this file.
;; If it is not present, you can access it from
;; https://www.gnu.org/licenses/agpl.txt (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;;

(in-package #:map)

(defmethod norm ((vec vector))
  (sqrt (loop for i across vec sum (* i i))))

(defun dot (a b)
  "Dot product of two vectors.  Returns a scalar."
  (assert (= (length a) (length b)))
  (reduce #'+ (map 'vector '* a b)))

(defun mean (vector)
  (/ (sum vector) (length vector)))

(defmethod sum ((vector vector))
  (loop for i across vector sum i))

Fix silly loop boundary conditions

;; vector-operations.lisp
;;
;; Copyright (c) 2012 Matt Novenstern <fisxoj@gmail.com>
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 3 of
;; the GNU Affero General Public License as published by
;; the Free Software Foundation.
;;
;; This code is distributed in the hope that it will be useful,
;; but without any warranty; without even the implied warranty of
;; merchantability or fitness for a particular purpose. See the GNU
;; Affero General Public License for more details.
;;
;; Version 3 of the GNU Affero General Public License is in the file
;; LICENSE that was distributed with this file.
;; If it is not present, you can access it from
;; https://www.gnu.org/licenses/agpl.txt (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;;

(in-package #:map)

(defmethod norm ((vec vector))
  (sqrt (loop for i across vec sum (* i i))))

(defun dot (a b)
  "Dot product of two vectors.  Returns a scalar."
  (assert (= (length a) (length b)))
  (reduce #'+ (map 'vector '* a b)))

(defun mean (vector)
  (/ (sum vector) (length vector)))

(defmethod sum ((vector vector))
  (loop for i across vector sum i))

(defun range (vector min max)
  (map 'vector (lambda (n) (+ (mod (- n min) (abs (- max min))) min)) vector))


;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; Programmer: Kevin Rosenberg

(in-package #:cl-user)
(defpackage #:puri-system (:use #:cl #:asdf))
(in-package #:puri-system)

(defsystem puri
  :name "cl-puri"
  :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
  :licence "GNU Lesser General Public License"
  :description "Portable Universal Resource Indentifier Library"
  :components
  ((:file "src")))

(defmethod perform ((o test-op) (c (eql (find-system 'puri))))
  (oos 'load-op 'puri-tests)
  (oos 'test-op 'puri-tests))

(defsystem puri-tests
    :depends-on (:puri :ptester)
    :components
    ((:file "tests")))

(defmethod perform ((o test-op) (c (eql (find-system 'puri-tests))))
  (or (funcall (intern (symbol-name '#:do-tests)
		       (find-package :puri-tests)))
      (error "test-op failed")))

(defmethod operation-done-p ((o test-op) (c (eql (find-system 'puri-tests))))
  (values nil))

Fix license in the ASDF file

;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; Programmer: Kevin Rosenberg

(in-package #:cl-user)
(defpackage #:puri-system (:use #:cl #:asdf))
(in-package #:puri-system)

(defsystem puri
  :name "cl-puri"
  :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
  :licence "Lisp Lesser GNU General Public License"
  :description "Portable Universal Resource Indentifier Library"
  :components
  ((:file "src")))

(defmethod perform ((o test-op) (c (eql (find-system 'puri))))
  (oos 'load-op 'puri-tests)
  (oos 'test-op 'puri-tests))

(defsystem puri-tests
    :depends-on (:puri :ptester)
    :components
    ((:file "tests")))

(defmethod perform ((o test-op) (c (eql (find-system 'puri-tests))))
  (or (funcall (intern (symbol-name '#:do-tests)
		       (find-package :puri-tests)))
      (error "test-op failed")))

(defmethod operation-done-p ((o test-op) (c (eql (find-system 'puri-tests))))
  (values nil))


(cl:in-package #:sicl-extrinsic-file-compiler)

(defparameter *sicl* (make-instance 'sicl-target-sicl:sicl))

(defparameter *gnu-linux* (make-instance 'sicl-os-gnu-linux:gnu-linux))

(defparameter *x86-64* (make-instance 'sicl-x86-64:x86-64))

(defun ast-from-stream (stream environment)
  (cleavir-ast:make-progn-ast
   (loop with eof = (list nil)
	 for form = (sicl-reader:read stream nil eof)
	 until (eq form eof)
	 collect (cleavir-generate-ast:generate-ast form environment))))

(defun compile-stream (stream environment)
  (let* ((cleavir-generate-ast:*compiler* 'cl:compile-file)
	 (ast (ast-from-stream stream environment))
	 (hir (cleavir-ast-to-hir:compile-toplevel ast))
	 (hir-bis (cleavir-hir-transformations:hir-transformations
		   hir
		   *sicl*
		   *gnu-linux*
		   *x86-64*)))
    hir-bis))

(defun compile-file (filename environment)
  (with-open-file (stream filename :direction :input)
    (compile-stream stream environment)))

Use correct order of arguments.

(cl:in-package #:sicl-extrinsic-file-compiler)

(defparameter *sicl* (make-instance 'sicl-target-sicl:sicl))

(defparameter *gnu-linux* (make-instance 'sicl-os-gnu-linux:gnu-linux))

(defparameter *x86-64* (make-instance 'sicl-x86-64:x86-64))

(defun ast-from-stream (stream environment)
  (cleavir-ast:make-progn-ast
   (loop with eof = (list nil)
	 for form = (sicl-reader:read stream nil eof)
	 until (eq form eof)
	 collect (cleavir-generate-ast:generate-ast form environment))))

(defun compile-stream (stream environment)
  (let* ((cleavir-generate-ast:*compiler* 'cl:compile-file)
	 (ast (ast-from-stream stream environment))
	 (hir (cleavir-ast-to-hir:compile-toplevel ast))
	 (hir-bis (cleavir-hir-transformations:hir-transformations
		   hir
		   *sicl*
		   *x86-64*
		   *gnu-linux*)))
    hir-bis))

(defun compile-file (filename environment)
  (with-open-file (stream filename :direction :input)
    (compile-stream stream environment)))


;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- FD mixin definitions
;;;

(in-package :iolib.streams)

(defmethod shared-initialize :around ((stream dual-channel-fd-mixin) slot-names &key)
  (declare (ignore slot-names))
  (call-next-method)
  (setf (isys:fd-nonblock-p (fd-of stream)) t))

;;;; CLOSE

(defmethod close :around ((fd-mixin dual-channel-fd-mixin)
                          &key abort)
  (declare (ignore abort))
  (call-next-method)
  (when (fd-of fd-mixin)
    (isys:close (fd-of fd-mixin))
    (setf (fd-of fd-mixin) nil)))

Make CLOSE of DUAL-CHANNEL-FD-MIXIN a primary method

;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- FD mixin definitions
;;;

(in-package :iolib.streams)

(defmethod shared-initialize :around ((stream dual-channel-fd-mixin) slot-names &key)
  (declare (ignore slot-names))
  (call-next-method)
  (setf (isys:fd-nonblock-p (fd-of stream)) t))

;;;; CLOSE

(defmethod close ((fd-mixin dual-channel-fd-mixin)
                  &key abort)
  (declare (ignore abort))
  (when (next-method-p) (call-next-method))
  (when (fd-of fd-mixin)
    (isys:close (fd-of fd-mixin))
    (setf (fd-of fd-mixin) nil)))


(in-package #:sdl2)

(defbitfield-from-cenum (sdl-window-flags
                         sdl2-ffi:sdl-windowflags
                         "SDL-WINDOW-")
  (:centered #x0))

(defun create-window (&key
                        (title "SDL2 Window")
                        (x windowpos-centered) (y windowpos-centered)
                        (w 800) (h 600) flags)
  (let ((window-flags (foreign-bitfield-value 'sdl-window-flags flags)))
    (sdl2-ffi:sdl-createwindow title x y w h window-flags)))

(defun destroy-window (win)
  (sdl2-ffi:sdl-destroywindow win))

Support :centered, :undefined for :x and :y

(in-package #:sdl2)

(defbitfield-from-cenum (sdl-window-flags
                         sdl2-ffi:sdl-windowflags
                         "SDL-WINDOW-")
  (:centered #x0))

(defun windowpos-undefined (&optional (display 0))
  (logior sdl2-ffi:+sdl-windowpos-undefined-mask+
          display))

(defun windowpos-centered (&optional (display 0))
  (logior sdl2-ffi:+sdl-windowpos-centered-mask+
          display))

(defun windowpos-from-coord (n)
  (case n
    (:undefined (windowpos-undefined))
    (:centered (windowpos-centered))
    (t n)))

(defun create-window (&key
                        (title "SDL2 Window")
                        (x :centered) (y :centered)
                        (w 800) (h 600) flags)
  (let ((window-flags (foreign-bitfield-value 'sdl-window-flags flags))
        (x (windowpos-from-coord x))
        (y (windowpos-from-coord y)))
    (sdl2-ffi:sdl-createwindow title x y w h window-flags)))

(defun destroy-window (win)
  (sdl2-ffi:sdl-destroywindow win))


(defvar *dist-url* "http://beta.quicklisp.org/dist/quicklisp/2018-07-11/distinfo.txt")

(load "quicklisp.lisp")

(quicklisp-quickstart:install :path "/opt/app-root/quicklisp/" :dist-url *dist-url*)

; Pre-load/compile useful content...
(ql:quickload :hunchentoot)
(ql:quickload :swank)

(with-open-file (out "/opt/app-root/.sbclrc" :direction :output)
  (format out "(load \"/opt/app-root/quicklisp\/setup.lisp\")")
  (format out "(ql:quickload :swank)")
  (format out "(swank:create-server :port 4005 :dont-close t)"))

Update quicklisp dist version to 2018-12-10

(defvar *dist-url* "http://beta.quicklisp.org/dist/quicklisp/2018-12-10/distinfo.txt")

(load "quicklisp.lisp")

(quicklisp-quickstart:install :path "/opt/app-root/quicklisp/" :dist-url *dist-url*)

; Pre-load/compile useful content...
(ql:quickload :hunchentoot)
(ql:quickload :swank)

(with-open-file (out "/opt/app-root/.sbclrc" :direction :output)
  (format out "(load \"/opt/app-root/quicklisp\/setup.lisp\")")
  (format out "(ql:quickload :swank)")
  (format out "(swank:create-server :port 4005 :dont-close t)"))


;;;; -*- mode: lisp; indent-tabs-mode: nil -*-
(in-package :crypto-tests)

(rtest:deftest :prng-fortuna (run-test-vector-file :prng *prng-tests*) t)

;;    (random-data (make-prng :fortuna :seed (coerce #(0) 'simple-octet-vector)) 1) #(28))

Add test of (MAKE-PRNG :FORTUNA :SEED URANDOM)

;;;; -*- mode: lisp; indent-tabs-mode: nil -*-
(in-package :crypto-tests)

(rtest:deftest :prng-fortuna (run-test-vector-file :prng *prng-tests*) t)
(rtest:deftest :prng-fortuna-urandom (let ((prng (crypto:make-prng :fortuna :seed urandom)))
                                       (= (length (crypto:random-data 16 prng))
                                          16)) t)

;;    (random-data (make-prng :fortuna :seed (coerce #(0) 'simple-octet-vector)) 1) #(28))


(cl:in-package #:sicl-clos)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FUNCALLABLE-STANDARD-CLASS.

(defclass funcallable-standard-class (regular-class)
  ())

Add copyright dates and license statement.

;;;; Copyright (c) 2010 - 2015
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or
;;;; without modification, are permitted provided that the following
;;;; conditions are met:
;;;;
;;;; 1. Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above
;;;;    copyright notice, this list of conditions and the following
;;;;    disclaimer in the documentation and/or other materials
;;;;    provided with the distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
;;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;; POSSIBILITY OF SUCH DAMAGE.

(cl:in-package #:sicl-clos)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FUNCALLABLE-STANDARD-CLASS.

(defclass funcallable-standard-class (regular-class)
  ())


;;;; Copyright (c) 2016 Henry Harrington <henry.harrington@gmail.com>
;;;; This code is licensed under the MIT license.

(in-package :cold-generator.arm64)

(defparameter *undefined-function-thunk*
  `((:comment todo))
  "Code for the undefined function thunk.")

(defparameter *closure-trampoline*
  `((:comment todo))
  "Trampoline used for calling a closure or funcallable-instance via an fref.")

(defparameter *funcallable-instance-trampoline*
  `((:comment todo))
  "Trampoline used for calling a closure or funcallable-instance via a funcallable-instance.")

Insert trap instructions into the assembly trampolines.

;;;; Copyright (c) 2016 Henry Harrington <henry.harrington@gmail.com>
;;;; This code is licensed under the MIT license.

(in-package :cold-generator.arm64)

(defparameter *undefined-function-thunk*
  `((:comment todo)
    (mezzano.lap.arm64:hlt 123))
  "Code for the undefined function thunk.")

(defparameter *closure-trampoline*
  `((:comment todo)
    (mezzano.lap.arm64:hlt 124))
  "Trampoline used for calling a closure or funcallable-instance via an fref.")

(defparameter *funcallable-instance-trampoline*
  `((:comment todo)
    (mezzano.lap.arm64:hlt 125))
  "Trampoline used for calling a closure or funcallable-instance via a funcallable-instance.")