(defpackage :autowrap.test
  (:use #:cl #:autowrap))

(in-package :autowrap.test)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (cffi-sys:%load-foreign-library
   :libtest (merge-pathnames "libtest.so" (asdf-path 'cl-autowrap-test))))

(c-include '(cl-autowrap-test "test.h")
           :spec-path '(cl-autowrap-test))

(let ((foo (get-foo)))
  (:say foo)
  (:say (foo-t.a foo))
  (:say (foo-t.x[].a foo 0))
  (:say (foo-t.x[].f foo 1))
  (:say (foo-t.x[].b0 foo 0))
  (:say (foo-t.x[].b1 foo 0))
  (:say (cffi-sys:%mem-ref (ptr foo) :unsigned-char (+ 16 24)))
  (setf (foo-t.x[].b0 foo 0) #b01)
  (setf (foo-t.x[].b1 foo 0) #b110)
  (print-bits foo)
  (free-foo foo))

(defpackage :autowrap.test
  (:use #:cl #:autowrap))

(in-package :autowrap.test)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (cffi-sys:%load-foreign-library
   :libtest (merge-pathnames "libtest.so" (asdf-path 'cl-autowrap-test))))

(c-include '(cl-autowrap-test "test.h")
           :spec-path '(cl-autowrap-test))

#+(or)
(let ((foo (get-foo)))
  (:say foo)
  (:say (foo-t.a foo))
  (:say (foo-t.x[].a foo 0))
  (:say (foo-t.x[].f foo 1))
  (:say (foo-t.x[].b0 foo 0))
  (:say (foo-t.x[].b1 foo 0))
  (:say (cffi-sys:%mem-ref (ptr foo) :unsigned-char (+ 16 24)))
  (setf (foo-t.x[].b0 foo 0) #b01)
  (setf (foo-t.x[].b1 foo 0) #b110)
  (print-bits foo)
  (free-foo foo))

Exclude forms reliant on external definitions


;;;; $Id$
;;;; $Source$

;;;; See LICENSE for licensing information.

(in-package :usocket)

(defun handle-condition (condition &optional (socket nil))
  "Dispatch correct usocket condition."
  (typecase condition
    (condition (error 'usocket-error
                      :real-condition condition
                      :socket socket))))

(defun open (host port &optional (type :stream))
  (declare (ignore type))
  (let ((socket (sock:make-socket :remote-host host
                                  :remote-port port)))
    (make-socket :socket socket :stream socket)))

(defmethod close ((usocket usocket))
  "Close socket."
  (sock:close (socket usocket)))

(defun get-host-by-address (address)
  (sock:lookup-host address))

(defun get-hosts-by-name (name)
  (sock:lookup-host name))

;;;; $Id$
;;;; $Source$

;;;; See LICENSE for licensing information.

(in-package :usocket)

(defun handle-condition (condition &optional (socket nil))
  "Dispatch correct usocket condition."
  (typecase condition
    (condition (error 'usocket-error
                      :real-condition condition
                      :socket socket))))

(defun open (host port &optional (type :stream))
  (declare (ignore type))
  (let ((socket (sock:make-socket :remote-host host
                                  :remote-port port)))
    (make-socket :socket socket :stream socket)))

(defmethod close ((usocket usocket))
  "Close socket."
  (sock:close (socket usocket)))

(defun get-host-by-address (address)
  (sock:ipaddr-to-hostname address))

(defun get-hosts-by-name (name)
  ;;###FIXME: ACL has the acldns module which returns all A records
  ;; only problem: it doesn't fall back to tcp (from udp) if the returned
  ;; structure is too long.
  (list (hbo-to-vector-quad (sock:lookup-hostname name))))

Update with latest documentation research.


(in-package #:deb-packager)

(defun run (command)
  (multiple-value-bind (output error-output status)
      (uiop:run-program command :output t :error-output t :ignore-error-status t)
    (unless (= status 0)
      (format t "An error occured~%"))
    (values output error-output)))

(defun run-in-chroot (folder command)
  (run (cat "chroot " folder " bash -c '" command "'")))

(defun cat (&rest args)
  (apply #'concatenate 'string args))

(defun build-source (source-folder chroot-folder arch depends repository)
  (let ((project-folder (first (last (pathname-directory (pathname source-folder))))))
    (run (cat "mkdir -p " chroot-folder))
    (run (cat "cdebootstrap --arch " arch
              " stable "
              chroot-folder
              " " repository
              " --include=" (format nil "~{~A~^,~}" depends)))
    (run (cat "cp -Rp " (namestring source-folder) " " chroot-folder "/tmp/"))
    (run-in-chroot chroot-folder "mkdir -p /tmp/installed")
    (run-in-chroot chroot-folder (cat "cd /tmp/" project-folder "; ./configure && make && make DESTDIR=/tmp/installed install"))))

(in-package #:deb-packager)

(defun run (command)
  (multiple-value-bind (output error-output status)
      (uiop:run-program command :output t :error-output t :ignore-error-status t)
    (unless (= status 0)
      (format t "An error occured~%"))
    (values output error-output)))

(defun run-in-chroot (folder command)
  (run (cat "fakeroot fakecroot chroot " folder " bash -c '" command "'")))

(defun cat (&rest args)
  (apply #'concatenate 'string args))

(defun build-source (source-folder chroot-folder arch depends repository)
  (let ((project-folder (first (last (pathname-directory (pathname source-folder))))))
    (run (cat "mkdir -p " chroot-folder))
    (run (cat "fakeroot cdebootstrap --arch " arch
              " stable "
              chroot-folder
              " " repository
              " --include=" (format nil "~{~A~^,~}" depends)))
    (run (cat "cp -Rp " (namestring source-folder) " " chroot-folder "/tmp/"))
    (run-in-chroot chroot-folder "mkdir -p /tmp/installed")
    (run-in-chroot chroot-folder (cat "cd /tmp/" project-folder "; ./configure && make && make DESTDIR=/tmp/installed install"))))

Use fakeroot for local development

Use fakeroot for local development


(in-package :med)

(defvar *mark-stack* ())

(defun function-source-file (function-symbol)
   (read-from-string
     (sixth (sys.int::function-pool-object (symbol-function function-symbol) 1))))

(defun function-top-level-form-number (function-symbol)
   (seventh (sys.int::function-pool-object (symbol-function function-symbol) 1)))

(defun find-definition (function-symbol)
  (let ((file (function-source-file function-symbol))
        (form (function-top-level-form-number function-symbol)))
    (find-file file)
    (let ((buffer (current-buffer *editor*)))
      (move-beginning-of-buffer buffer)
      (dotimes (i (1+ form))
        (move-sexp buffer))
    (move-sexp buffer -1))))

(defun find-definition-command ()
  (find-definition (read-from-string (symbol-at-point (current-buffer *editor*)))))

(in-package :med)

(defvar *mark-stack* ())

(defun function-source-file (function-symbol)
   (read-from-string
     (sixth (sys.int::function-pool-object (symbol-function function-symbol) 1))))

(defun function-top-level-form-number (function-symbol)
   (seventh (sys.int::function-pool-object (symbol-function function-symbol) 1)))

(defun find-definition (function-symbol)
  (let ((file (function-source-file function-symbol))
        (form (function-top-level-form-number function-symbol)))
    (find-file file)
    (let* ((buffer (current-buffer *editor*))
           (*package* (buffer-current-package buffer)))
      (move-beginning-of-buffer buffer)
      (dotimes (i (1+ form))
        (move-sexp buffer))
    (move-sexp buffer -1))))

(defun find-definition-command ()
  (find-definition (read-from-string (symbol-at-point (current-buffer *editor*)))))

Set *package* when trying to find definition.


;;; Copyright 2012-2020 Google LLC
;;;
;;; Use of this source code is governed by an MIT-style
;;; license that can be found in the LICENSE file or at
;;; https://opensource.org/licenses/MIT.

(in-package #:cl-protobufs.test)

;;; A suite to contain all other test suites so there's an easy entry point to
;;; run all tests.
(clunit:defsuite root-suite ())

(defun run-all ()
  "Run all tests."
  (clunit:run-suite 'root-suite))

;;; Copyright 2012-2020 Google LLC
;;;
;;; Use of this source code is governed by an MIT-style
;;; license that can be found in the LICENSE file or at
;;; https://opensource.org/licenses/MIT.

(in-package #:cl-protobufs.test)

;;; A suite to contain all other test suites so there's an easy entry point to
;;; run all tests.
(clunit:defsuite root-suite ())

(defun run-all ()
  "Run all tests."
  (print (clunit:run-suite 'root-suite)))

Call (print result) on root-test so we get the result of the test run.

There's a bug in clunit where it doesn't print the results of a
test run when we call run-suite unless it's run from the repl.
This is, bizarre. It's been fixed upstream but quicklisp
is only updated once a month, so until then...

PiperOrigin-RevId: 324942086


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

(define-built-in-class function (t)
  ((%entry-point :initarg :entry-point)
   (%linkage-rack :initarg :linkage-rack)
   (%environment :initform nil :initarg :environment)))

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

(defclass function (t)
  ((%entry-point :initarg :entry-point)
   (%linkage-rack :initarg :linkage-rack)
   (%environment :initform nil :initarg :environment))
  (:metaclass built-in-class))

Define class FUNCTION using DEFCLASS rather than obsolete macro DEFINE-BUILT-IN-CLASS.


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

(defun create-bridge-classes (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (ld "../CLOS/t-defclass.lisp" c r)
    (ld "../CLOS/standard-object-defclass.lisp" c r)
    (ld "../CLOS/metaobject-defclass.lisp" c r)
    (ld "../CLOS/method-combination-defclass.lisp" c r)
    (ld "../CLOS/slot-definition-defclass.lisp" c r)
    (ld "../CLOS/standard-slot-definition-defclass.lisp" c r)
    (ld "../CLOS/direct-slot-definition-defclass.lisp" c r)
    (ld "../CLOS/specializer-defclass.lisp" c r)
    (ld "../CLOS/class-defclass.lisp" c r)
    (ld "../CLOS/forward-referenced-class-defclass.lisp" c r)
    (ld "../CLOS/real-class-defclass.lisp" c r)
    (ld "../CLOS/regular-class-defclass.lisp" c r)
    (ld "../CLOS/built-in-class-defclass.lisp" c r)
    (ld "../CLOS/standard-class-defclass.lisp" c r)
    (ld "../CLOS/funcallable-standard-class-defclass.lisp" c r)))

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

(defun create-bridge-classes (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (ld "../CLOS/t-defclass.lisp" c r)
    (ld "../CLOS/standard-object-defclass.lisp" c r)
    (ld "../CLOS/metaobject-defclass.lisp" c r)
    (ld "../CLOS/method-combination-defclass.lisp" c r)
    (ld "../CLOS/slot-definition-defclass.lisp" c r)
    (ld "../CLOS/standard-slot-definition-defclass.lisp" c r)
    (ld "../CLOS/direct-slot-definition-defclass.lisp" c r)
    (ld "../CLOS/effective-slot-definition-defclass.lisp" c r)
    (ld "../CLOS/specializer-defclass.lisp" c r)
    (ld "../CLOS/class-defclass.lisp" c r)
    (ld "../CLOS/forward-referenced-class-defclass.lisp" c r)
    (ld "../CLOS/real-class-defclass.lisp" c r)
    (ld "../CLOS/regular-class-defclass.lisp" c r)
    (ld "../CLOS/built-in-class-defclass.lisp" c r)
    (ld "../CLOS/standard-class-defclass.lisp" c r)
    (ld "../CLOS/funcallable-standard-class-defclass.lisp" c r)))

Load a file containing the definition of EFFECTIVE-SLOT-DEFINITION.


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

;;;; This definition of the macro DEFMETHOD is less general than the
;;;; normal definition.  It is only guaranteed to work when the
;;;; generic function is of type STANDARD-GENERIC-FUNCTION, and the
;;;; method to be created can be of type STANDARD-METHOD.
;;;;
;;;; The advantage of this definition is that it does not require the
;;;; full generality of MAKE-METHOD-LAMBDA.  Instead, it uses the
;;;; default version of MAKE-METHOD-LAMBDA.

(defmacro defmethod (function-name &rest rest)
  (multiple-value-bind
	(qualifiers lambda-list specializers declarations documentation forms)
      (parse-defmethod rest)
    (let ((generic-function-var (gensym)))
      `(let* ((rt-env (load-time-value (sicl-genv:global-environment)))
	      (,generic-function-var
		(ensure-generic-function ',function-name
					 :environment rt-env)))
	 (ensure-method
	  ,generic-function-var
	  rt-env
	  :lambda-list ',lambda-list
	  :qualifiers ',qualifiers
	  :specializers ,(canonicalize-specializers specializers)
	  :documentation ,documentation
	  :function
	  ,(sicl-clos::make-method-lambda-default
	    nil nil
	    `(lambda ,lambda-list
	       ,@declarations
	       ,@forms)
	    nil))))))

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

;;;; This definition of the macro DEFMETHOD is less general than the
;;;; normal definition.  It is only guaranteed to work when the
;;;; generic function is of type STANDARD-GENERIC-FUNCTION, and the
;;;; method to be created can be of type STANDARD-METHOD.
;;;;
;;;; The advantage of this definition is that it does not require the
;;;; full generality of MAKE-METHOD-LAMBDA.  Instead, it uses the
;;;; default version of MAKE-METHOD-LAMBDA.

(defmacro defmethod (function-name &rest rest)
  (multiple-value-bind
	(qualifiers lambda-list specializers declarations documentation forms)
      (parse-defmethod rest)
    `(temporary-ensure-method
      ',function-name
      ',lambda-list
      ',qualifiers
      ,(canonicalize-specializers specializers)
      ,documentation
      ,(sicl-clos::make-method-lambda-default
	nil nil
	`(lambda ,lambda-list
	   ,@declarations
	   ,@forms)
	nil))))

Call TEMPORARY-ENSURE-METHOD rather than ENSURE-METHOD.


(in-package #:asdf-user)

(defsystem :sicl-iteration
  :depends-on (:cleavir-code-utilities
	       :cleavir-internationalization
	       :sicl-iteration-support)
  :serial t
  :components
  ((:file "dotimes-defmacro")
   (:file "dolist-defmacro")
   (:file "do-dostar-defmacro")))

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

(defsystem :sicl-iteration
  :depends-on (:cleavir-code-utilities
	       :cleavir-internationalization
	       :sicl-iteration-support)
  :serial t
  :components
  ((:file "dotimes-defmacro")
   (:file "dolist-defmacro")
   (:file "do-dostar-defmacro")))

Use explicit package prefix for IN-PACKAGE.


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

(defun %member-r (elm lst)
  (dolist (i lst)
    (when (equal elm i)
	  (return i))))

(defun member (elm &rest lsts)
  (dolist (i lsts)
    (awhen (%member-r elm i)
	  (return !))))

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

(defun %member-r (elm lst)
  (while lst
         nil
    (when (equal elm lst.)
	  (return lst))
    (setf lst .lst)))

(defun member (elm &rest lsts)
  (dolist (i lsts)
    (awhen (%member-r elm i)
	  (return !))))

MEMBER: Return list starting with found element.


(defsystem "petalisp.type-inference"
  :author "Marco Heisig <marco.heisig@fau.de>"
  :license "AGPLv3"

  :depends-on
  ("alexandria"
   "trivia"
   "trivial-arguments")

  :in-order-to ((test-op (test-op "petalisp.test-suite")))

  :serial t
  :components
  ((:file "packages")
   (:file "auxiliary-types")
   (:file "function-lambda-lists")
   (:file "ntype-1")
   (:file "ntype-2")
   (:file "ntype-3")
   (:file "conditions")
   (:file "special-functions")
   (:file "define-rule")
   (:file "define-instruction")
   (:file "specialize")
   (:module "common-lisp"
    :components
    ((:file "auxiliary")
     (:file "abs")
     (:file "add")
     (:file "casts")
     (:file "cmpeq")
     (:file "cmpneq")
     (:file "cmpx")
     (:file "cos")
     (:file "data-and-control-flow")
     (:file "div")
     (:file "max")
     (:file "min")
     (:file "mul")
     (:file "predicates")
     (:file "sin")
     (:file "sub")
     (:file "tan")
     (:file "type-checks")
     (:file "types-and-classes")))))

(defsystem "petalisp.type-inference"
  :author "Marco Heisig <marco.heisig@fau.de>"
  :license "AGPLv3"

  :depends-on
  ("alexandria"
   "trivia"
   "trivial-arguments")

  :in-order-to ((test-op (test-op "petalisp.test-suite")))

  :serial t
  :components
  ((:file "packages")
   (:file "auxiliary-types")
   (:file "function-lambda-lists")
   (:file "ntype-1")
   (:file "ntype-2")
   (:file "ntype-3")
   (:file "conditions")
   (:file "special-functions")
   (:file "define-rule")
   (:file "define-instruction")
   (:file "specialize")
   (:module "common-lisp"
    :components
    ((:file "auxiliary")
     (:file "type-checks")
     (:file "casts")
     (:file "abs")
     (:file "add")
     (:file "cmpeq")
     (:file "cmpneq")
     (:file "cmpx")
     (:file "cos")
     (:file "data-and-control-flow")
     (:file "div")
     (:file "max")
     (:file "min")
     (:file "mul")
     (:file "predicates")
     (:file "sin")
     (:file "sub")
     (:file "tan")
     (:file "types-and-classes")))))

Load type inference definitions in the right order.


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

;;;  (c) copyright 2009 by
;;;           Cyrus Harmon (ch-lisp@bobobeach.com)
;;;
;;; 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.

(asdf:defsystem :mcclim-tiff-bitmaps
  :description "Support for TIFF images in McCLIM bitmap reading functions."
  :depends-on (:mcclim :retrospectiff)
  :components ((:file "tiff" :pathname #P"Extensions/Bitmap-formats/tiff")))

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

;;;  (c) copyright 2009 by
;;;           Cyrus Harmon (ch-lisp@bobobeach.com)
;;;
;;; 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 #:asdf-user)

(defsystem :mcclim-tiff-bitmaps
  :description "Support for TIFF images in McCLIM bitmap reading functions."
  :depends-on (:mcclim :retrospectiff)
  :components ((:file "tiff" :pathname #P"Extensions/Bitmap-formats/tiff")))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


(ql:quickload "quicklisp-slime-helper")
(let ((swank::*loopback-interface* (sb-unix:unix-gethostname)))
  (swank:create-server :dont-close t))
(load "/piserv/piserv.asd")
(ql:quickload "piserv")
(piserv:start-server 8080)
(loop (sleep 5))

(ql:quickload "quicklisp-slime-helper")
(let ((swank::*loopback-interface* (sb-unix:unix-gethostname)))
  (swank:create-server :dont-close t))
(sb-posix:chdir #P"/piserv/")
(load "/piserv/piserv.asd")
(ql:quickload "piserv")
(piserv:start-server 8080)
(loop (sleep 5))

Add chdir to enable git

Add chdir to enable git


(fn json-encode (x)  (json_encode x))
(fn json-decode (x)  (json_decode x))

(fn json-encode (x)  (json_encode x))
(fn json-decode (x)  (json_decode x t))

JS-DECODE: Return associative arrays instead of objects.


(defpackage :glkit.asdf
  (:use #:cl #:asdf))

(in-package :glkit.asdf)

#+(or (and sbcl (not (or win32 windows))) ccl cmucl ecl lispworks allegro)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew :glkit-sv *features*))

(defsystem :glkit
  :description "Various utilities for OpenGL"
  :author ("rpav")
  :license "MIT"
  :version "0.0"

  :depends-on (:alexandria :defpackage-plus :sb-cga :mathkit
               :cl-opengl #+glkit-sv :static-vectors)
  :pathname "src"
  :serial t

  :components
  ((:file "package")
   (:file "protocol")

   (:module "shader-dict"
    :serial t
    :pathname "shader-dict"
    :components
    ((:file "shaders")
     (:file "uniforms")
     (:file "macros")))

   (:module "vao"
    :serial t
    :pathname "vao"
    :components
    ((:file "vao")))

   (:module "tex"
    :serial t
    :pathname "tex"
    :components
    ((:file "util")
     (:file "texture")
     (:file "fbo")))))

(defpackage :glkit.asdf
  (:use #:cl #:asdf))

(in-package :glkit.asdf)

#+(or allegro ccl cmu ecl lispworks sbcl)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew :glkit-sv *features*))

(defsystem :glkit
  :description "Various utilities for OpenGL"
  :author ("rpav")
  :license "MIT"
  :version "0.0"

  :depends-on (:alexandria :defpackage-plus :sb-cga :mathkit
               :cl-opengl #+glkit-sv :static-vectors)
  :pathname "src"
  :serial t

  :components
  ((:file "package")
   (:file "protocol")

   (:module "shader-dict"
    :serial t
    :pathname "shader-dict"
    :components
    ((:file "shaders")
     (:file "uniforms")
     (:file "macros")))

   (:module "vao"
    :serial t
    :pathname "vao"
    :components
    ((:file "vao")))

   (:module "tex"
    :serial t
    :pathname "tex"
    :components
    ((:file "util")
     (:file "texture")
     (:file "fbo")))))

Enable static-vectors support on sbcl/windows.

I remember I reported a static-vectors bug for sbcl/windows a few years ago that was fixed in 22a816 and d3a07d, which is why this exclusion was present. This is no longer the case, and needed for some projects I have tested to even function on Windows.


(div :class "imageform"
  (input :type "hidden" :name "id[]" :value ,(param 'id))
  (a :href ,(param 'link-image-large)
    (img :src ,(param 'image-src)))
  (textarea :rows "2" :name "title[]" ,(param 'title))
  (select :name "country[]" ,(flag-options (param 'country)))
  (input :type "text" :name "price[]" :size "8" :value ,(param 'price))
  (br)
  (input :type "checkbox" :name ,(+ "f_public[" *image-index* "]") :value "1"
         ,@(& (string== "1" (param 'f_public))
              `(:checked "checked"))
    ,(lang de "öffentlich"
           en "public"))
  (button :onclick ,(alet (param 'title)
                      (+ "javascript: if (confirm ('"
                         (lang en (+ "Really remove this image with the title\\n"" ! ""?")
                               de (+ "Dieses Bild mit dem Titel\\n" " ! ""\\nwirklich entfernen?"))
                         "')) { window.location = '" (action-url :add (list 'remove-image (param 'id))) "'; return false; }"))
      ,(lang de "entfernen"
             en "remove")))

(div :class "imageform"
  (input :type "hidden" :name "id[]" :value ,(param 'id))
  (a :href ,(param 'link-image-large)
    (img :src ,(param 'image-src)))
  (textarea :rows "2" :name "title[]" ,(param 'title))
  (select :name "country[]" ,(flag-options (param 'country)))
  (input :type "text" :name "price[]" :size "8" :value ,(param 'price))
  (br)
  (input :type "checkbox" :name ,(+ "f_public[" *image-index* "]") :value "1"
         ,@(& (string== "1" (param 'f_public))
              `(:checked "checked"))
    ,(lang de "öffentlich"
           en "public"))
  (button :onclick ,(alet (param 'title)
                      (+ "javascript: if (confirm ('"
                         (lang en (+ "Really remove this image with the title "" ! ""?")
                               de (+ "Dieses Bild mit dem Titel\\n" " ! "" wirklich entfernen?"))
                         "')) { window.location = '" (action-url :add (list 'remove-image (param 'id))) "'; return false; }"))
      ,(lang de "entfernen"
             en "remove")))

Remove printf() control code from alert text.


(cl:in-package #:cleavir-ast)

(defclass scope-ast (ast)
  ((%child-ast :initarg :child-ast :reader child-ast)
   (%variable-ast :initarg :variable-ast :reader variable-ast)))

(cleavir-io:define-save-info scope-ast
  (:child-ast child-ast)
  (:variable-ast variagble-ast))

(cl:in-package #:cleavir-ast)

(defclass scope-ast (ast)
  ((%child-ast :initarg :child-ast :reader child-ast)
   (%variable-ast :initarg :variable-ast :reader variable-ast)))

(cleavir-io:define-save-info scope-ast
  (:child-ast child-ast)
  (:variable-ast variable-ast))

(defun make-scope-ast (variable-ast child-ast &key origin)
  (make-instance 'scope-east
    :origin origin
    :variable-ast variable-ast
    :child-ast child-ast))

Define constructor for new AST class.

Define constructor for new AST class.


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

(defun ld (filename environment1 environment2)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (sicl-extrinsic-environment:load-source-with-environments
   (asdf:system-relative-pathname :sicl-boot-phase1 filename)
   environment1
   environment2))

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

(defun ld (filename environment1 environment2)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (sicl-extrinsic-environment:load-source-with-environments
   (asdf:system-relative-pathname :sicl-boot filename)
   environment1
   environment2))

Load files relative to new boot system.

Load files relative to new boot system.


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

(defsystem clump
  :depends-on (:clump-binary-tree :clump-splay-tree))

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

(defsystem clump
  :depends-on (:clump-binary-tree))

Remove system :CLUMP-SPLAY-TREE from :DEPENDS-ON list.


;;;; p31.lisp
;;;; Determine whether a given integer number is prime

(in-package :99-questions)

(defun primep (n)
  (= n (first (last (prime-list n)))))

;;; Sieve of Eratosthenes
(defun prime-list (max)
  (let ((numbers (make-array (1+ max) :initial-element t)))
    (loop for contender from 2 to max
       when (aref numbers contender)
       collect contender
       do (loop for multiple from contender to max by contender
	     do (setf (aref numbers multiple) nil)))))

;;;; p31.lisp
;;;; Determine whether a given integer number is prime

(in-package :99-questions)

(defun primep (n)
  (= n (first (last (prime-list n)))))

(defun prime-list (max)
  "Evaluates to a list of all prime numbers smaller or equal to max
   using the Sieve of Eratosthenes algorithm."
  (when (plusp max)
    (let ((numbers (make-array (1+ max) :initial-element t)))
      (loop for contender from 2 to max
         when (aref numbers contender)
         collect contender
         do (loop for multiple from contender to max by contender
               do (setf (aref numbers multiple) nil))))))

Add a test for positive numbers in prime-list


;;;; nix operating system project
;;;; list processor environment
;;;; Copyright (C) 2006 Sven Klose <pixel@copei.de>

(defvar *tests* nil)

(%defun punchcard-equal (x y)
  (cond
    ((atom x)	 (eql x y))
    ((atom y)	 (eql x y))
    ((punchcard-equal (car x) (car y))
      		 (punchcard-equal (cdr x) (cdr y)))))

(%defun do-test (test)
  (cond
    ((punchcard-equal 	(eval (car (cdr test)))
                      	(eval (car (cdr (cdr test))))))
                  (t    (print (car test))
			(print 'FAILED)
			(invoke-debugger))))

(%defun do-tests (tests)
  (cond
    ((not tests))
    (t			(do-test (car tests))
			(do-tests (cdr tests)))))

;; Add test to global list.
(%defspecial define-test (description expr result)
  (setq *tests* (cons (cons description
		            (cons (cons (quote block)
				        (cons (quote nil)
                                              expr))
				  (cons result nil)))
                        *tests*))
  (do-test (car *tests*)))

;;;; nix operating system project
;;;; list processor environment
;;;; Copyright (C) 2006 Sven Klose <pixel@copei.de>

(defvar *tests* nil)

(%defun punchcard-equal (x y)
  (cond
    ((atom x)	 (eql x y))
    ((atom y)	 (eql x y))
    ((punchcard-equal (car x) (car y))
      		 (punchcard-equal (cdr x) (cdr y)))))

(%defun do-test (test)
  (cond
    ((punchcard-equal 	(eval (car (cdr test)))
                      	(eval (car (cdr (cdr test))))))
                  (t    (print (car test))
			(print 'FAILED-RESULT)
			(print (eval (car (cdr test))))
			(print 'WANTED-RESULT)
			(print (eval (car (cdr (cdr test)))))
			(invoke-debugger))))

(%defun do-tests (tests)
  (cond
    ((not tests))
    (t			(do-test (car tests))
			(do-tests (cdr tests)))))

;; Add test to global list.
(%defspecial define-test (description expr result)
  (setq *tests* (cons (cons description
		            (cons (cons (quote block)
				        (cons (quote nil)
                                              expr))
				  (cons result nil)))
                        *tests*))
  (do-test (car *tests*)))

Print failed and wanted result of test.

Print failed and wanted result of test.


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

(asdf:defsystem glaw
  :license "MIT"
  :version "git"
  :description "Game programming utilities"
  :depends-on (:cl-opengl :cl-openal :cl-alc)
  :components
  ((:module "src"
            :serial t
            :components
            ((:file "package")
             (:file "utils")
             (:file "resource")
             (:file "assets")
             (:file "input")
             (:file "graphics")
             (:file "anim")
             (:file "2d")
             (:file "gui")
             (:file "font")
             (:file "particles")
             (:file "screen")
             (:file "scheduler")
             (:file "navmesh")
             (:file "skeleton")
             (:file "sound")
             (:file "console")))))

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

(asdf:defsystem glaw
  :license "MIT"
  :version "git"
  :description "Game programming utilities"
  :depends-on (:cl-opengl :cl-openal :cl-alc)
  :components
  ((:module "src"
            :serial t
            :components
            ((:file "package")
             (:file "utils")
             (:file "math")
             (:file "resource")
             (:file "assets")
             (:file "input")
             (:file "graphics")
             (:file "anim")
             (:file "2d")
             (:file "gui")
             (:file "font")
             (:file "particles")
             (:file "screen")
             (:file "scheduler")
             (:file "navmesh")
             (:file "skeleton")
             (:file "sound")
             (:file "console")))))

Add the new math file to the system.

Add the new math file to the system.


(ros:include "util")
(defpackage :roswell.dump.sbcl
  (:use :cl :roswell.util))
(in-package :roswell.dump.sbcl)

(defun dump-executable (cmds out script)
  (declare (ignore script))
  (sb-ext:save-lisp-and-die
   out
   ;; no need to do GC because of :purify t by default
   ;; however, this only affects old cheyneyGC
   ;; http://www.sbcl.org/manual/#Efficiency-Hacks
   :purify t ; just here to make it explicit
   :toplevel
   #'(lambda ()
       (setf *load-pathname* (pathname (first sb-ext:*posix-argv*)))
       (setf ros:*argv* (rest sb-ext:*posix-argv*))
       (ros:run cmds))
   :executable t
   :save-runtime-options t))

(defun sbcl (type &rest args)
  (case type
    (:executable
     (apply 'dump-executable args))))

(ros:include "util")
(defpackage :roswell.dump.sbcl
  (:use :cl :roswell.util))
(in-package :roswell.dump.sbcl)

(defun dump-executable (cmds out script)
  (declare (ignore script))
  (sb-ext:save-lisp-and-die
   out
   ;; no need to do GC because of :purify t by default
   ;; however, this only affects old cheyneyGC
   ;; http://www.sbcl.org/manual/#Efficiency-Hacks
   :purify t ; just here to make it explicit
   :compression t ; we all want our programs to be small, right?
   :toplevel
   #'(lambda ()
       (setf *load-pathname* (pathname (first sb-ext:*posix-argv*)))
       (setf ros:*argv* (rest sb-ext:*posix-argv*))
       (ros:run cmds))
   :executable t
   :save-runtime-options t))

(defun sbcl (type &rest args)
  (case type
    (:executable
     (apply 'dump-executable args))))

Use compression when building executable with SBCL.


(cl:in-package #:sicl-global-environment)

(defmacro defun (&environment env name lambda-list &body body)
  (multiple-value-bind (declarations documentation forms)
      (cleavir-code-utilities:separate-function-body body)
    (let ((global-env (cleavir-env:global-environment env))
	  (arg-type
	    (cleavir-code-utilities:lambda-list-type-specifier lambda-list)))
      `(progn
	 (eval-when (:compile-toplevel :load-toplevel :execute)
	   (setf (sicl-env:function-type ',name ,global-env)
		 `(function ,',arg-type t)))
	 (eval-when (:load-toplevel :execute)
	   (setf (sicl-env:fdefinition ',name ,global-env)
		 (lambda ,lambda-list
		   ,@declarations
		   ,@(if (null documentation)
			 '()
			 (list documentation))
		   (block ,(if (symbolp name) name (second name))
		     ,@forms)))
	   ',name)))))

(cl:in-package #:sicl-global-environment)

(defmacro defun (&environment env name lambda-list &body body)
  (multiple-value-bind (declarations documentation forms)
      (cleavir-code-utilities:separate-function-body body)
    (let ((global-env (cleavir-env:global-environment env))
	  (arg-type
	    (cleavir-code-utilities:lambda-list-type-specifier lambda-list)))
      `(progn
	 (eval-when (:compile-toplevel :load-toplevel :execute)
	   (setf (sicl-env:function-type ',name ,global-env)
		 `(function ,',arg-type t)))
	 (eval-when (:load-toplevel :execute)
	   (setf (sicl-env:fdefinition ',name (sicl-genv:global-environment))
		 (lambda ,lambda-list
		   ,@declarations
		   ,@(if (null documentation)
			 '()
			 (list documentation))
		   (block ,(if (symbolp name) name (second name))
		     ,@forms)))
	   ',name)))))

Define function in run-time environment rather than in compilation environment.


(defpackage :test.fastech.string
  (:use :cl
        :cl-test-more
        :fastech))
(in-package :test.fastech.string)

(plan 3)

(diag "str")
(is (parse (str "foo") "foobar")
    (values "foo" "bar")
    "parses a string")

(diag "satisfy")
(flet ((pred (char)
         (eq char #\a)))
  (is (parse (satisfy #'pred) "abc")
      (values #\a "bc")
      "parses the satisfied char")
  (is-error (parse (satisfy #'pred) "bac")
            'parse-error
            "failes parsing the satisfied char"))

(finalize)

(defpackage :test.fastech.string
  (:use :cl
        :cl-test-more
        :fastech))
(in-package :test.fastech.string)

(plan 4)

(diag "str")
(is (parse (str "foo") "foobar")
    (values "foo" "bar")
    "parses a string")
(is-error (parse (str "foo") "barfoo")
          'parse-error
          "fails parsing invalid input")

(diag "satisfy")
(flet ((pred (char)
         (eq char #\a)))
  (is (parse (satisfy #'pred) "abc")
      (values #\a "bc")
      "parses the satisfied char")
  (is-error (parse (satisfy #'pred) "bac")
            'parse-error
            "fails parsing the unsatisfied char"))

(finalize)

Add a test about str

Add a test about str


;;; -*- Mode: Lisp; Package: User -*-

(in-package :common-lisp-user)

;;; Needed to keep ACL from issuing warnings about toplevel (shadow ...) forms
(setq comp:*cltl1-compile-file-toplevel-compatibility-p* nil)

(defpackage :clim-mop
  (:use :clos)
  (:import-from :common-lisp
		#:class-name)
  (:export #:class-name))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (do-external-symbols (sym :clos)
	(export sym :clim-mop)))

#+NIL
(progn
  (eval-when (:compile-toplevel :load-toplevel :execute)
    (defvar clim-lisp-patch::*inline-functions* nil))

  (defmacro clim-lisp-patch:declaim (&rest args)
    (dolist (arg args)
      (cond ((and (consp arg) (eq (car arg) 'inline))
             (dolist (k (cdr arg))
               (pushnew k clim-lisp-patch::*inline-functions*)))))
    `(declaim ,@args) )

  (defmacro clim-lisp-patch:defun (fun args &body body)
    (cond ((member fun clim-lisp-patch::*inline-functions*)
           (cond ((and (consp fun) (eq (car fun) 'setf))
                  (let ((fnam (intern (concatenate 'string
                                        "(SETF " (symbol-name (cadr fun)) ")")
                                      (symbol-package (cadr fun)))))
                    `(progn
                       (defsetf ,(cadr fun) (&rest ap) (new-value)
                         (list* ',fnam new-value ap))
                       (defun ,fnam ,args .,body)
                       (define-compiler-macro ,fnam (&rest .args.)
                         (cons '(lambda ,args .,body)
                               .args.)))))
                 (t
                  `(progn
                     (defun ,fun ,args .,body)
                     (define-compiler-macro ,fun (&rest .args.)
                       (cons '(lambda ,args .,body)
                             .args.))))))
          (t
           `(defun ,fun ,args ,@body)))) )

Patch to teach ACL inline functions, though commented out.

Does anybody know, which versions of ACL are capable/incapable of
inlining functions, and how to #+-test for it?


;;; Copyright 2008 Gabor Balazs
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;;
;;; $Date$

(in-package #:org.rl-community.rl-glue-codec)

(defun get-svn-codec-version ()
  (let ((glue-ver "$Revision$"))
    (subseq glue-ver 11 (- (length glue-ver) 2))))

(defun get-codec-version ()
  "1.0-RC2")

;;; Copyright 2008 Gabor Balazs
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;;
;;; $Date$

(in-package #:org.rl-community.rl-glue-codec)

(defun get-svn-codec-version ()
  (let ((glue-ver "$Revision$"))
    (subseq glue-ver 11 (- (length glue-ver) 2))))

(defun get-codec-version ()
  "1.0-RC3")

Change version from RC2 to RC3.

Change version from RC2 to RC3.


;;;; $Id$
;;;; $Source$

;;;; See LICENSE for licensing information.

(in-package :usocket)

(defun handle-condition (condition &optional (socket nil))
  "Dispatch correct usocket condition."
  (typecase condition
    (condition (error 'usocket-error
                      :real-condition condition
                      :socket socket))))

(defun open (host port &optional (type :stream))
  (declare (ignore type))
  (let ((socket (sock:make-socket :remote-host host
                                  :remote-port port)))
    (make-socket :socket socket :stream socket)))

(defmethod close ((usocket usocket))
  "Close socket."
  (sock:close (socket usocket)))

(defun get-host-by-address (address)
  (sock:lookup-host address))

(defun get-hosts-by-name (name)
  (sock:lookup-host name))

;;;; $Id$
;;;; $Source$

;;;; See LICENSE for licensing information.

(in-package :usocket)

(defun handle-condition (condition &optional (socket nil))
  "Dispatch correct usocket condition."
  (typecase condition
    (condition (error 'usocket-error
                      :real-condition condition
                      :socket socket))))

(defun open (host port &optional (type :stream))
  (declare (ignore type))
  (let ((socket (sock:make-socket :remote-host host
                                  :remote-port port)))
    (make-socket :socket socket :stream socket)))

(defmethod close ((usocket usocket))
  "Close socket."
  (sock:close (socket usocket)))

(defun get-host-by-address (address)
  (sock:ipaddr-to-hostname address))

(defun get-hosts-by-name (name)
  ;;###FIXME: ACL has the acldns module which returns all A records
  ;; only problem: it doesn't fall back to tcp (from udp) if the returned
  ;; structure is too long.
  (list (hbo-to-vector-quad (sock:lookup-hostname name))))

Update with latest documentation research.


(cl:in-package #:sicl-source-tracking-reader)

(defun make-contents ()
  (make-array 10
	      :fill-pointer 0
	      :element-type 'character
	      :adjustable t))

(defclass source-tracking-stream
    (trivial-gray-streams:fundamental-character-input-stream)
  ((%original :initarg :original :reader original)
   (%contents :initform (make-contents) :reader contents)
   (%index :initform 0 :accessor index)
   (%line :initform 0 :accessor line)
   (%column :initform 0 :accessor column)))

(defun make-source-tracking-stream (stream)
  (make-instance 'source-tracking-stream
    :original stream))

(defmethod trivial-gray-streams:stream-read-char
    ((stream source-tracking-stream))
  (let ((char (trivial-gray-streams:stream-read-char (original stream))))
    (vector-push-extend char (contents stream) 10)
    (if (eql char #\Newline)
	(progn (setf (column stream) 0)
	       (incf (line stream)))
	(incf (column stream)))
    char))

(cl:in-package #:sicl-source-tracking-reader)

(defun make-contents ()
  (make-array 10
	      :fill-pointer 0
	      :element-type 'character
	      :adjustable t))

(defclass source-tracking-stream
    (trivial-gray-streams:fundamental-character-input-stream)
  ((%original :initarg :original :reader original)
   (%contents :initform (make-contents) :reader contents)
   (%index :initform 0 :accessor index)
   (%line :initform 0 :accessor line)
   (%column :initform 0 :accessor column)
   (%char-to-read :initform nil :accessor char-to-read)))

(defun make-source-tracking-stream (stream)
  (make-instance 'source-tracking-stream
    :original stream))

(defmethod trivial-gray-streams:stream-read-char
    ((stream source-tracking-stream))
  (let ((char (trivial-gray-streams:stream-read-char (original stream))))
    (vector-push-extend char (contents stream) 10)
    (if (eql char #\Newline)
	(progn (setf (column stream) 0)
	       (incf (line stream)))
	(incf (column stream)))
    char))

Create a one-char buffer for UNREAD-CHAR.


(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)
  (ld "../../CLOS/ensure-generic-function-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment))

(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)
  (ld "../../CLOS/ensure-generic-function-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment)
  (setf (sicl-genv:find-class 'standard-object environment) nil)
  (ld "../../CLOS/standard-object-defclass.lisp" environment))

Load file containing definition of class STANDARD-OBJECT.


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

(defpackage #:sicl-cons
  (:use #:common-lisp)
  (:export
   ;; The symbols LOAD-CAR, LOAD-CDR, STORE-CAR, and STORE-CDR name
   ;; special operators.  The operators LOAD-CAR and LOAD-CDR are
   ;; similar to the functions CAR and CDR, except that they require
   ;; that the argument be a CONS, or else an error is signaled.  The
   ;; operators STORE-CAR and STORE-CDR are like the functions RPLACA
   ;; and RPLACD, except that they must be evaluated in a context
   ;; where no value is required.
   #:load-car #:load-cdr #:store-car #:store-cdr
   ))

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

(defpackage #:sicl-cons
  (:use #:common-lisp)
  (:export
   ))

Remove initial low-level operations in favor of Cleavir PRIMOPs.


(defsystem #:local-time
  :name "local-time"
  :version "1.0.1"
  :author "Daniel Lowe <dlowe@dlowe.net>"
  :description "A library for manipulating dates and times, based on a paper by Erik Naggum"
  :depends-on (:cl-fad)
  :serial t
  :components ((:module "src"
                :components ((:file "package")
                             (:file "local-time")))))

(defmethod perform ((op test-op) (system (eql (find-system :local-time))))
  (asdf:load-system :local-time.test)
  (eval (read-from-string "(hu.dwim.stefil:funcall-test-with-feedback-message 'local-time.test::test)")))

(defsystem #:local-time
  :name "local-time"
  :version "1.0.3"
  :author "Daniel Lowe <dlowe@dlowe.net>"
  :description "A library for manipulating dates and times, based on a paper by Erik Naggum"
  :depends-on (:cl-fad)
  :serial t
  :components ((:module "src"
                :components ((:file "package")
                             (:file "local-time")))))

(defmethod perform ((op test-op) (system (eql (find-system :local-time))))
  (asdf:load-system :local-time.test)
  (eval (read-from-string "(hu.dwim.stefil:funcall-test-with-feedback-message 'local-time.test::test)")))

Fix version number to match actual version


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

(defun make-contents ()
  (make-array 10
	      :fill-pointer 0
	      :element-type 'character
	      :adjustable t))

(defclass source-tracking-stream
    (trivial-gray-streams:fundamental-character-input-stream)
  ((%original :initarg :original :reader original)
   (%contents :initform (make-contents) :reader contents)
   (%index :initform 0 :accessor index)
   (%line :initform 0 :accessor line)
   (%column :initform 0 :accessor column)))

(defun make-source-tracking-stream (stream)
  (make-instance 'source-tracking-stream
    :original stream))

(defmethod trivial-gray-streams:stream-read-char
    ((stream source-tracking-stream))
  (let ((char (trivial-gray-streams:stream-read-char (original stream))))
    (vector-push-extend char (contents stream) 10)
    (when (eql char #\Newline)
      (setf (column stream) 0)
      (incf (line stream)))
    char))

Define method on STREAM-READ-CHAR specialized to SOURCE-TRACKING-STREAM.


(defpackage #:info.isoraqathedh.umpns.asdf
  (:use #:cl #:asdf))
(in-package #:info.isoraqathedh.umpns.asdf)

(defsystem my-project
  :name "UMPNS-based Minor Planet Namer"
  :version "0.1"
  :license "MIT"
  :components ((:file "unified-minor-planet-naming-system")
               (:module "sub-directory"
                :components (:file "subdir-lisp-source-file"))))

(defpackage #:info.isoraqathedh.umpns.asdf
  (:use #:cl #:asdf))
(in-package #:info.isoraqathedh.umpns.asdf)

(defsystem umpns
  :name "UMPNS-based Minor Planet Namer"
  :version "0.1"
  :license "MIT"
  :components ((:file "unified-minor-planet-naming-system"))
  :depends-on (:cl-ppcre :cl-sqlite))

Add dependencies. Also, fixed the rest of the mess


;; Common Lisp Script
;; Manoel Vilela

(asdf/defsystem:defsystem :lisp-chat
  :author "Manoel Vilela"
  :email "manoel_vilela@engineer.com"
  :version "0.1"
  :license "MIT"
  :depends-on ("usocket")
  :components ((:file "config")
               (:file "client" :depends-on ("config"))
               (:file "server" :depends-on ("config"))))

;; Common Lisp Script
;; Manoel Vilela

(asdf/defsystem:defsystem :lisp-chat
  :author "Manoel Vilela"
  :description "An experimental chat irc-like"
  :version "0.1"
  :license "MIT"
  :depends-on ("usocket")
  :components ((:file "config")
               (:file "client" :depends-on ("config"))
               (:file "server" :depends-on ("config"))))

Remove invalid :email keyword and add :descrption @ asdf definition

I'm having some troubles about the static compiling and the variables
defined on config.lisp. On the ASDF system compilation the *host*,
*port* and *debug* is tagged as UNDEFINED. This is pretty weird.
How I can fix that?


(in-package :6502-tests)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require 'sb-sprof))

(def-suite performance :in 6502-tests)
(in-suite performance)

(defun profile-klaus-suite (&key (mode :time))
  "MODE may be :TIME, :CPU, or :ALLOC. Load Klaus' test suite and use SBCL's
statistical profiler to observe performance while running the test suite."
  (klaus-init)
  (sb-sprof:with-profiling (:max-samples 1000
                            :show-progress t
                            :report :graph
                            :mode mode
                            :reset t)
    (loop until (> (cpu-cc *cpu*) (* 45 (expt 2 21)))
       do (6502-step *cpu* (get-byte (immediate *cpu*))))))

(deftest keep-it-fast
    "We should not have deteriorating performance. 24.576 seconds at most."
  ;; NOTE: This test based on 64-bit SBCL 1.1.4 on my Debian Thinkpad X200.
  (klaus-init)
  (let ((start (get-internal-real-time)))
    (klaus-test)
    (is (< (- (get-internal-real-time) start) #x6000))))

(in-package :6502-tests)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require 'sb-sprof))

(def-suite performance :in 6502-tests)
(in-suite performance)

(defun profile-klaus-suite (&key (mode :time))
  "MODE may be :TIME, :CPU, or :ALLOC. Load Klaus' test suite and use SBCL's
statistical profiler to observe performance while running the test suite."
  (klaus-init)
  (sb-sprof:with-profiling (:max-samples 1000
                            :show-progress t
                            :report :graph
                            :mode mode
                            :reset t)
    (loop until (> (cpu-cc *cpu*) (* 45 (expt 2 21)))
       do (6502-step *cpu* (get-byte (immediate *cpu*))))))

(defun optimize-test ()
  (reset *cpu*)
  (klaus-init)
  (time (loop until (> (cpu-cc *cpu*) (* 1.79 (expt 2 20)))
           do (6502-step *cpu* (get-byte (immediate *cpu*))))))

(deftest keep-it-fast
    "We should not have deteriorating performance. 24.576 seconds at most."
  ;; NOTE: This test based on 64-bit SBCL 1.1.4 on my Debian Thinkpad X200.
  (klaus-init)
  (let ((start (get-internal-real-time)))
    (klaus-test)
    (is (< (- (get-internal-real-time) start) #x6000))))

Add an OPTIMIZE-TEST similar to that in famiclom to cl-6502.


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

(defsystem :sicl-sequence-support
  :serial t
  :components
  ((:file "packages")
   (:file "find")
   (:file "position")))

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

(defsystem :sicl-sequence-support
  :serial t
  :components
  ((:file "packages")
   (:file "utilities")
   (:file "find")
   (:file "position")))

Add existing component utilities to system definition.


; find the shortest path between two nodes in an unweighted graph
; ie perform a breadth first search

; the graph is a list of nodes
; a node is a list whose first element is the name of the node
; and whose remaining elements are the names of any neighbours
; (set-graph '((a b c) (b a) (c a)))

(setq graph nil)
(defun set-graph (graph-as-list)
  (setf graph graph-as-list))

(defun find-node (node-name)
  (defun next-node (unchecked-graph)
    (cond ((null unchecked-graph) nil)
          ((equal node-name (caar unchecked-graph)) (car unchecked-graph))
          (t (next-node (cdr unchecked-graph)))))
  (next-node graph))

(defun neighbours (node-name)
  (cdr (find-node node-name)))

(defun appears-in (target llist)
  (cond ((null llist) nil)
        ((equal (car llist) target) t)
        (t (appears-in (cdr llist)))))

Write own version of member predicate called appears-in


(fn list-string-0 (x)
  (apply #'string-concat (@ #'string x)))

(fn list-string (x) ; TODO: Cleanup.
  (apply #'string-concat (@ #'list-string-0 (group x 16384))))

(fn list-string-0 (x)
  (apply #'string-concat (mapcar #'string x)))

(fn list-string (x)
  (apply #'string-concat (mapcar #'list-string-0 (group x 16384))))

Use MAPCAR instead of @.

Use MAPCAR instead of @.


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

(defclass enter-instruction (cleavir-ir:enter-instruction)
  ((%owned-variables :initarg :owned-variables :reader owned-variables)))

(defun lexical-value (lexical-variable process)
  (loop for table in (static-env (stack process))
	do (multiple-value-bind (value present-p)
	       (gethash lexical-variable table)
	     (when present-p
	       (return-from lexical-value value))))
  (error "unknown variable ~s" lexical-variable))

Access a lexical variable in the current process.


;;;  (c) copyright 2016 by
;;;           Robert Strandh (robert.strandh@gmail.com)

;;; 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 #:mcclim-clx-core)

;;; A point is said to be PAINTABLE if its coordinates are valid for
;;; X11.  Recall that coordinates in X11 are signed 16-bit integers.
(defun point-paintable-p (x y)
  (and (<= #x-8000 x #x7fff)
       (<= #x-8000 y #x7fff)))

Introduce the concept of a PAINTABLE point.


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

(in-package #:cl-user)
(asdf:defsystem #:plaster
  :defsystem-depends-on (:radiance)
  :class "radiance:virtual-module"
  :components ((:file "module")
               (:file "objects")
               (:file "frontend")
               (:file "api"))
  :depends-on ((:interface :database)
               (:interface :user)
               (:interface :auth)
               (:interface :profile)
               (:interface :rate)
               :r-data-model
               :r-clip
               :crypto-shortcuts))

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

(asdf:defsystem #:plaster
  :defsystem-depends-on (:radiance)
  :class "radiance:virtual-module"
  :components ((:file "module")
               (:file "objects")
               (:file "frontend")
               (:file "api"))
  :depends-on ((:interface :database)
               (:interface :user)
               (:interface :auth)
               (:interface :profile)
               (:interface :rate)
               :r-data-model
               :r-clip
               :crypto-shortcuts))

Remove in-package from ASD file.

Remove in-package from ASD file.


(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")
(defjump *jumps* "y" "https://www.youtube.com/results?search_query=~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))))

(in-package :lispkit)

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

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

(defjump *jumps* "g" "https://google.com/search?q=~a")
(defjump *jumps* "gh" "https://github.com/search?&q=~a")
(defjump *jumps* "y" "https://www.youtube.com/results?search_query=~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))))

Use HTTPS for the Google jump

Use HTTPS for the Google jump


(cl:defpackage #:anaphoric-variants_tests
  (:use #:cl #:parachute)
  (:import-from #:anaphoric-variants #:anaphoric))

(cl:in-package #:anaphoric-variants_tests)

(define-test "featured examples"
  (is equal
      (anaphoric tail
        (when (member 'b '(a b c d))
          (cdr tail)))
      '(c d))
  (is equal
      (anaphoric (key :type type :index index)
        (etypecase '(a b c)
          (list (list* index type key))
          (t (list index "Not a list." key))))
      '(0 list a b c))
  ;;; TODO: Test other anaphoric variants, and custom anaphoric variant definition.
  )

(cl:defpackage #:anaphoric-variants_tests
  (:use #:cl #:parachute)
  (:import-from #:anaphoric-variants #:anaphoric))

(cl:in-package #:anaphoric-variants_tests)

(define-test "featured examples"
  (is equal '(c d)
      (anaphoric tail
        (when (member 'b '(a b c d))
          (cdr tail))))
  (is equal '(0 list a b c)
      (anaphoric (key :type type :index index)
        (etypecase '(a b c)
          (list (list* index type key))
          (t (list index "Not a list." key)))))
  ;;; TODO: Test other anaphoric variants, and custom anaphoric variant definition.
  )

Use proper argument order for IS.

Tests: Use proper argument order for IS.


;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; * Portable lexical environment access

;;;; ** OpenMCL

#+openmcl
(defun environment-p (environment)
  (subtypep (class-of environment) 'ccl::lexical-environment))

#+openmcl
(defun lexical-variables (environment)
  (loop
     for env = environment then (ccl::lexenv.parent-env env)
     while env
     for vars = (ccl::lexenv.variables env)
     when (listp vars)
     append (mapcar (lambda (var)
                      ;; ccl::var-name is a macro, se we can't do #'ccl::var-name directly
                      (ccl::var-name var))
                    vars)))

;;;; ** SBCL

#+sbcl
(defun environment-p (environment)
  (subtypep (class-of environment) (find-class 'sb-kernel:lexenv)))

#+sbcl
(defun lexical-variables (environment)
  (mapcar #'first (sb-c::lexenv-vars environment)))

;;;; ** CMUCL

#+cmu
(defun environment-p (environment)
  (subtypep (class-of environment) (find-class 'c::lexenv)))

#+cmu
(defun lexical-variables (environment)
  (mapcar #'first (c::lexenv-variables environment)))

;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; * Portable lexical environment access

;;;; ** OpenMCL

#+openmcl
(defun environment-p (environment)
  (subtypep (class-of environment) 'ccl::lexical-environment))

#+openmcl
(defun lexical-variables (environment)
  (loop
     for env = environment
          then (ccl::lexenv.parent-env env)
     while (and env
                (not (ccl::istruct-typep env 'ccl::definition-environment)))
     for vars = (ccl::lexenv.variables env)
     when (listp vars)
     append (mapcar (lambda (var)
                      ;; ccl::var-name is a macro, se we can't do #'ccl::var-name directly
                      (ccl::var-name var))
                    vars)))

;;;; ** SBCL

#+sbcl
(defun environment-p (environment)
  (subtypep (class-of environment) (find-class 'sb-kernel:lexenv)))

#+sbcl
(defun lexical-variables (environment)
  (mapcar #'first (sb-c::lexenv-vars environment)))

;;;; ** CMUCL

#+cmu
(defun environment-p (environment)
  (subtypep (class-of environment) (find-class 'c::lexenv)))

#+cmu
(defun lexical-variables (environment)
  (mapcar #'first (c::lexenv-variables environment)))

Fix openmcl's definition of lexical-variables to deal with ccl::definition-environment

darcs-hash:20050719152230-dd2a1-020627dbba3080ad3dd9b8086e892978f81028d3.gz


(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)))

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

(defun ensure-class (name
		     &rest arguments
		     &key direct-superclasses metaclass
		     &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)))
	 (new-metaclass (if (null metaclass)
			    'standard-class
			    'closer-mop:funcallable-standard-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
			:metaclass new-metaclass
			new-arguments)))
      (setf (sicl-genv:find-class name environment) class)
      class)))

Handle metaclasses so that we can define funcallable classes.


(defsystem "mezzano-virgl"
  :components ((:file "package")
               (:file "virgl-protocol")
               (:file "virgl")
               (:file "tgsi")))

(defsystem "mezzano-virgl"
  :serial t
  :components ((:file "package")
               (:file "virgl-protocol")
               (:file "virgl")
               (:file "tgsi")
               (:file "test")))

Add test code to the asd

virgl: Add test code to the asd


(defsystem #:coleslaw
  :name "coleslaw-core"
  :description "Flexible Lisp Blogware"
  :version "0.7"
  :license "BSD"
  :author "Brit Butler <redline6561@gmail.com>"
  :pathname "src/"
  :depends-on (:closure-template
               :3bmd
               :3bmd-ext-code-blocks
               :alexandria
               :local-time
               :inferior-shell
               :cl-fad)
  :serial t
  :components ((:file "packages")
               (:file "util")
               (:file "config")
               (:file "themes")
               (:file "posts")
               (:file "indices")
               (:file "feeds")
               (:file "coleslaw"))
  :in-order-to ((test-op (load-op coleslaw-tests)))
  :perform (test-op :after (op c)
                    (funcall (intern "RUN!" :coleslaw-tests)
                             (intern "COLESLAW-TESTS" :coleslaw-tests))))

(defsystem #:coleslaw-tests
  :depends-on (coleslaw fiveam)
  :pathname "tests/"
  :serial t
  :components ((:file "packages")
               (:file "tests")))

(defmethod operation-done-p ((op test-op)
                             (c (eql (find-system :coleslaw))))
  (values nil))

(defpackage #:coleslaw-conf (:export #:*basedir*))
(defparameter coleslaw-conf:*basedir*
  (make-pathname :name nil :type nil :defaults *load-truename*))

(defsystem #:coleslaw
  :name "coleslaw-core"
  :description "Flexible Lisp Blogware"
  :version "0.7"
  :license "BSD"
  :author "Brit Butler <redline6561@gmail.com>"
  :pathname "src/"
  :depends-on (:closure-template
               :3bmd
               :3bmd-ext-code-blocks
               :alexandria
               :local-time
               :inferior-shell
               :cl-fad
               :cl-ppcre)
  :serial t
  :components ((:file "packages")
               (:file "util")
               (:file "config")
               (:file "themes")
               (:file "posts")
               (:file "indices")
               (:file "feeds")
               (:file "coleslaw"))
  :in-order-to ((test-op (load-op coleslaw-tests)))
  :perform (test-op :after (op c)
                    (funcall (intern "RUN!" :coleslaw-tests)
                             (intern "COLESLAW-TESTS" :coleslaw-tests))))

(defsystem #:coleslaw-tests
  :depends-on (coleslaw fiveam)
  :pathname "tests/"
  :serial t
  :components ((:file "packages")
               (:file "tests")))

(defmethod operation-done-p ((op test-op)
                             (c (eql (find-system :coleslaw))))
  (values nil))

(defpackage #:coleslaw-conf (:export #:*basedir*))
(defparameter coleslaw-conf:*basedir*
  (make-pathname :name nil :type nil :defaults *load-truename*))

Add formerly transitive dependency, cl-ppcre. Thanks Xach!


(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)
    )
)

(in-package :common-lisp-user)
(format t "loading xml-rpc...~%")

#+allegro
(require :xml-rpc)

#+allegro
(progn

  (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)

  (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)
    )
)

Put in-package in correct place

Put in-package in correct place

git-svn-id: 9ecf60ce9baff443e30a0472d3fd222fcb8117cf@3404 7b97033b-253e-4a5c-9b07-e25f9089a9fd


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

;;; This generic function can be used only on an empty tree.
(defgeneric insert (object tree))

(defmethod insert :before (object (tree tree))
  (unless (null (contents tree))
    (error "Do this error message better.")))

(defmethod insert (object (tree tree))
  (setf (contents tree)
	(make-instance (leaf-class tree)
	  :contents object
	  :parent tree
	  :tree tree)))

;;; In NODE, split child node OLD-CHILD into two child nodes,
;;; NEW-CHILD-1 and NEW-CHILD-2.
(defgeneric split (node old-child new-child-1 new-child-2))

;; In NODE, replace child OLD-CHILD with the node NEW-CHILD.
(defgeneric replace (node old-child new-child))

(defmethod replace ((node 2-node) old-child new-child)
  (if (eq old-child (left node))
      (setf (left node) new-child)
      (setf (right node) new-child)))

(defmethod replace ((node 3-node) old-child new-child)
  (if (eq old-child (left node))
      (setf (left node) new-child)
      (if (eq old-child (middle node))
	  (setf (middle node) new-child)
	  (setf (right node) new-child))))

(defmethod replace ((tree tree) old-child new-child)
  (declare (ignore old-child))
  (setf (contents tree) new-child))

Define method on REPLACE specialized to TREE.


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

(defun phase3 (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (define-effective-slot-definition-class boot)
    (ld "../CLOS/class-finalization-support.lisp" c r)
    (export-to-host 'sicl-clos::compute-default-initargs-default r)
    (export-to-host 'sicl-clos::compute-slots-default r)
    (export-to-host 'sicl-clos::compute-slots-around-default r)
    (export-to-host 'sicl-clos::compute-effective-slot-definition-default r)
    (export-to-host 'sicl-clos::compute-class-precedence-list-default r)
    (export-to-host 'sicl-clos::finalize-inheritance-default r)
    (export-to-host 'sicl-clos::effective-slot-definition-class r)
    (ld "../CLOS/class-finalization-defmethods.lisp" c r)))

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

(defclass header ()
  ((%class :initarg :class :accessor class)
   (%rack :initarg :rack :reader rack)))

(defun phase3 (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (define-effective-slot-definition-class boot)
    (ld "../CLOS/class-finalization-support.lisp" c r)
    (export-to-host 'sicl-clos::compute-default-initargs-default r)
    (export-to-host 'sicl-clos::compute-slots-default r)
    (export-to-host 'sicl-clos::compute-slots-around-default r)
    (export-to-host 'sicl-clos::compute-effective-slot-definition-default r)
    (export-to-host 'sicl-clos::compute-class-precedence-list-default r)
    (export-to-host 'sicl-clos::finalize-inheritance-default r)
    (export-to-host 'sicl-clos::effective-slot-definition-class r)
    (ld "../CLOS/class-finalization-defmethods.lisp" c r)))

Define a header class for general instances.


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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (fmakunbound 'defgeneric))

(defmacro defgeneric (name parameters)
  `(progn
     (let* ((class (find-bridge-class 'standard-generic-function))
	    (fun (make-instance-default class
		   :name ',name :lambda-list ',parameters)))
       (push (cons ',name fun) *target-generic-functions*))))

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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (fmakunbound 'defgeneric))

(defmacro defgeneric (name parameters)
  `(progn
     (let* ((class (find-bridge-class 'standard-generic-function))
	    (fun (make-instance-default class
		   :name ',name
		   :lambda-list ',parameters
		   :method-class (find-bridge-class 'standard-method))))
       (push (cons ',name fun) *target-generic-functions*))))

Make the bridge class STANDARD-METHOD the method class of target generic functions.


;;;; © 2016-2020 Marco Heisig         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.api)

(defalias a α)
(defalias a* α*)
(defalias alpha α)
(defalias α* α*)
(defalias b β)
(defalias b* β*)
(defalias beta β)
(defalias beta* β*)
(defalias tau τ)

;;;; © 2016-2020 Marco Heisig         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.api)

(defalias a α)
(defalias a* α*)
(defalias alpha α)
(defalias alpha* α*)
(defalias b β)
(defalias b* β*)
(defalias beta β)
(defalias beta* β*)
(defalias tau τ)

Add the accidentally omitted alpha* function alias.


(defpackage #:cqlcl-test
  (:use :cl :cqlcl :lisp-unit))

(in-package #:cqlcl-test)

(define-test parse-options-header
  (labels ((hash-equal (h1 h2)
             (maphash (lambda (k v)
                        (assert-equal (gethash k h2) (values v t))) h1)))
    (let* ((packet #(129 0 0 6 0 0 0 52 0 2 0 11 67 81 76 95 86 69 82
                     83 73 79 78 0 1 0 5 51 46 49 46 50 0 11 67 79 77
                     80 82 69 83 83 73 79 78 0 2 0 6 115 110 97 112 112
                     121 0 3 108 122 52))
           (expected-hash (alexandria:alist-hash-table
                           '(("CQL_VERSION" . ("3.1.2"))
                             ("COMPRESSION" . ("snappy" "lz4"))) :test #'equalp))
           (parsed (parse-packet packet)))
      (hash-equal parsed expected-hash))))

(define-test simple-connection
  (let* ((conn (make-connection))
         (conopt (gethash "COMPRESSION" (conn-options conn)))
         (expected (values '("snappy" "lz4") t)))
    (assert-equal conopt expected)))

Add test for a simple connection

Add test for a simple connection


(in-package :vsanalizer)

(defun string-at-offset (table offset)
  "Retrieves a string from the string table TABLE
   starting from offset OFFSET"
  (let ((end-pos (position 0 table :start offset)))
    (map 'string #'code-char (subseq table offset end-pos))))

(defun get-funcs (elf-obj &key dynamicp)
  "Returns a list of functions (as named regions) from ELF-OBJ.
   DYNAMICP specifies the symbol table to be used."
  (let ((string-table (named-section elf-obj
                                     (if dynamicp ".dynstr" ".strtab")))
        (symtable (named-section elf-obj
                                 (if dynamicp ".dynsym" ".symtab"))))
    (if (and string-table
             symtable)
        (flet ((cons-entry (sym)
                 (make-named-region :start (value sym)
                                    :end (+ (value sym) (size sym))
                                    :name (string-at-offset (data string-table) (name sym))))
               (present-function-p (sym)
                 (and
                  (= (shndx sym) 12) ; FIXME: is this .text?
                  (eq (elf:type sym) :func))))

          (mapcar #'cons-entry (remove-if-not #'present-function-p (data symtable)))))))

(in-package :vsanalizer)

(defun sym-name (str-table symbol)
  "Retrieves the name of a SYMBOL from the string table STR-TABLE"
  (let ((table-data (data str-table))
        (beg-pos (name symbol)))
    (map 'string #'code-char (subseq table-data beg-pos
                                     (position 0 table-data :start beg-pos)))))

(defun text-section-idx (elf-obj)
  "Returns postion of .text section in section header table"
  (flet ((text-section-p (sec)
           (string= (name sec) ".text")))
    (position-if #'text-section-p (sections elf-obj))))

(defun get-funcs (elf-obj &key dynamicp)
  "Returns a list of functions (as named regions) from ELF-OBJ.
   DYNAMICP specifies the symbol table to be used."
  (let ((string-table (named-section elf-obj
                                     (if dynamicp ".dynstr" ".strtab")))
        (symtable (named-section elf-obj
                                 (if dynamicp ".dynsym" ".symtab")))
        (text-section-idx (text-section-idx elf-obj)))
    (if (and string-table
             symtable)
        (flet ((cons-entry (sym)
                 (make-named-region :start (value sym)
                                    :end (+ (value sym) (size sym))
                                    :name (sym-name string-table sym)))
               (present-function-p (sym)
                 (and
                  (= (shndx sym) text-section-idx)
                  (eq (elf:type sym) :func))))

          (mapcar #'cons-entry (remove-if-not #'present-function-p (data symtable)))))))

Deal with location of .text section in section header table correctly


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

(defpackage #:cleavir-cst
  (:use #:common-lisp)
  (:export
   #:canonicalize-declaration-specifier
   #:cst-is-declaration-p
   #:cst-is-literal-string-p
   #:separate-ordinary-body
   #:separate-function-body
   #:optional-or-keyword-parameter
   #:variables-cst
   #:init-form-cst
   #:supplied-p-parameter-cst
   #:optional-parameter
   #:optional-parameters
   #:keyword-cst
   #:parameters
   #:keyword-parameter
   #:keyword-name-cst
   #:keyword-parameters))

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

(defpackage #:cleavir-cst
  (:use #:common-lisp)
  (:export
   #:canonicalize-declaration-specifier
   #:cst-is-declaration-p
   #:cst-is-literal-string-p
   #:separate-ordinary-body
   #:separate-function-body
   #:facultative-parameter
   #:variables-cst
   #:init-form-cst
   #:supplied-p-parameter-cst
   #:facultative-parameter
   #:optional-parameter
   #:facultative-parameters
   #:optional-parameters
   #:keyword-cst
   #:parameters
   #:keyword-parameter
   #:keyword-name-cst
   #:keyword-parameters))

Adjust package export list according to recent modifications of classes.


(cl:in-package #:cleavir-remove-useless-instructions)

(defgeneric instruction-may-be-removed-p (instruction))

(defmethod instruction-may-be-removed-p (instruction)
  (and (= (length (cleavir-ir:successors instruction)) 1)
       (loop for output in (cleavir-ir:outputs instruction)
	     always (null (cleavir-ir:using-instructions output)))))

(defmethod instruction-may-be-removed-p
    ((instruction cleavir-ir:enter-instruction))
  nil)

(defmethod instruction-may-be-removed-p
    ((instruction cleavir-ir:unwind-instruction))
  nil)

(defun remove-useless-instructions (initial-instruction)
  (cleavir-ir:reinitialize-data initial-instruction)
  (let ((useless-instructions '()))
    (cleavir-ir:map-instructions-arbitrary-order
     (lambda (instruction)
       (when (and (= (length (cleavir-ir:successors instruction)) 1)
		  (not (typep instruction 'cleavir-ir:funcall-instruction))
		  (loop for output in (cleavir-ir:outputs instruction)
			always (null (cleavir-ir:using-instructions output))))
	 (push instruction useless-instructions)))
     initial-instruction)
    (mapc #'cleavir-ir:delete-instruction useless-instructions)))

(cl:in-package #:cleavir-remove-useless-instructions)

(defgeneric instruction-may-be-removed-p (instruction))

(defmethod instruction-may-be-removed-p (instruction)
  (and (= (length (cleavir-ir:successors instruction)) 1)
       (loop for output in (cleavir-ir:outputs instruction)
	     always (null (cleavir-ir:using-instructions output)))))

(defmethod instruction-may-be-removed-p
    ((instruction cleavir-ir:enter-instruction))
  nil)

(defmethod instruction-may-be-removed-p
    ((instruction cleavir-ir:unwind-instruction))
  nil)

(defmethod instruction-may-be-removed-p
    ((instruction cleavir-ir:funcall-instruction))
  nil)

(defun remove-useless-instructions (initial-instruction)
  (cleavir-ir:reinitialize-data initial-instruction)
  (let ((useless-instructions '()))
    (cleavir-ir:map-instructions-arbitrary-order
     (lambda (instruction)
       (when (and (= (length (cleavir-ir:successors instruction)) 1)
		  (not (typep instruction 'cleavir-ir:funcall-instruction))
		  (loop for output in (cleavir-ir:outputs instruction)
			always (null (cleavir-ir:using-instructions output))))
	 (push instruction useless-instructions)))
     initial-instruction)
    (mapc #'cleavir-ir:delete-instruction useless-instructions)))

Add method specialized to FUNCALL-INSTRUCTION.


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

(defgeneric left (node))
(defgeneric right (node))
(defgeneric (setf left) (new-left node))
(defgeneric (setf right) (new-right node))

(defclass node ()
  ((%left :initarg :left :initform nil :accessor left)
   (%right :initarg :right :initform nil :accessor right)))

(defgeneric node-p (tree)
  (:method (tree) nil)
  (:method ((tree node)) t))

(defmethod initialize-instance :before ((object node) &key left right)
  (unless (or (null left) (node-p left))
    (error 'invalid-binary-tree :tree left))
  (unless (or (null right) (node-p right))
    (error 'invalid-binary-tree :tree right)))

(defclass simple-node (node)
  ())

(defclass node-with-parent (node)
  ((%parent :initarg :parent :initform nil :accessor parent)))

(defmethod (setf left) :after
    ((new-left node-with-parent) (node node-with-parent))
  (setf (parent new-left) node))

(defmethod (setf right) :after
    ((new-right node-with-parent) (node node-with-parent))
  (setf (parent new-right) node))

Add an :AFTER method on (SETF RIGHT) specialized to NODE-WITH-PARENT.


(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))

(defmethod delete-child ((tree tree) child)
  (declare (ignore child))
  (setf (contents tree) nil))

(defmethod delete-child ((node 2-node) child)
  (replace-and-shrink (parent node)
		      (if (eq child (left node))
			  (right node)
			  (left node))))

Define method on DELETE-CHILD specialized to 2-NODE.


(fn props-alist (x)
  (@ [. _ (slot-value x _)] (property-names x)))

(fn alist-props (x)
  (& x
     (aprog1 (new)
       (@ (i x)
         (= (slot-value ! i.) .i)))))

(fn merge-props (a b)
  (aprog1 (new)
    (@ (i (property-names a))
      (= (slot-value ! i) (slot-value a i)))
    (@ (i (property-names b))
      (= (slot-value ! i) (slot-value b i)))))

(fn copy-props (x)
  (merge-props x nil))

(fn add-props (x &rest props)
  (merge-props x (apply #'make-object props)))

(fn remove-prop (props key)
  (aprog1 (new)
    (@ (i (property-names props))
      (| (eql i key)
         (= (slot-value ! i) (slot-value props i))))))

(fn props-alist (x)
  (mapcar [. _ (slot-value x _)] (property-names x)))

(fn alist-props (x)
  (& x
     (aprog1 (new)
       (@ (i x)
         (= (slot-value ! i.) .i)))))

(fn merge-props (a b)
  (aprog1 (new)
    (@ (i (property-names a))
      (= (slot-value ! i) (slot-value a i)))
    (@ (i (property-names b))
      (= (slot-value ! i) (slot-value b i)))))

(fn copy-props (x)
  (merge-props x nil))

(fn add-props (x &rest props)
  (merge-props x (apply #'make-object props)))

(fn remove-prop (props key)
  (aprog1 (new)
    (@ (i (property-names props))
      (| (eql i key)
         (= (slot-value ! i) (slot-value props i))))))

Use MAPCAR instead of @.

Use MAPCAR instead of @.


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

;;; The macro DEFINE-BUILT-IN-CLASS expands to a call to this
;;; function, and this function is used only in that situation.  For
;;; that reason, we do not have to be particularly thorough about
;;; checking the validity of arguments.
;;;
;;; The argument DIRECT-SUPERCLASS-NAMES is a list of SYMBOLS.  Unlike
;;; the function ENSURE-CLASS we do not allow for class metaobject
;;; superclasses.
(defun ensure-built-in-class (name
			      &rest arguments
			      &key
				direct-default-initargs
				direct-superclass-names
			      &allow-other-keys)
  ;; If the class already exists, then do nothing.
  (when (null (find-class name nil))
    (let ((superclasses (loop for name in direct-superclass-names
			      for class = (find-bridge-class name)
			      collect class))
	  (remaining-keys (copy-list arguments)))
      (loop while (remf remaining-keys :direct-superclasses))
      (let ((result (apply #'cl:make-instance
			   'sicl-boot-phase1:built-in-class
			   :direct-default-initargs direct-default-initargs
			   :name name
			   :direct-superclasses superclasses
			   remaining-keys)))
	(add-bridge-class name result)
	;; FIXME: this is where we add create the accessors.
	result))))

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

;;; The macro DEFINE-BUILT-IN-CLASS expands to a call to this
;;; function, and this function is used only in that situation.  For
;;; that reason, we do not have to be particularly thorough about
;;; checking the validity of arguments.
;;;
;;; The argument DIRECT-SUPERCLASS-NAMES is a list of SYMBOLS.  Unlike
;;; the function ENSURE-CLASS we do not allow for class metaobject
;;; superclasses.
(defun ensure-built-in-class (name
			      &rest arguments
			      &key
				direct-default-initargs
				direct-superclasses
			      &allow-other-keys)
  ;; If the class already exists, then do nothing.
  (when (null (find-bridge-class name nil))
    (let ((superclasses (loop for name in direct-superclasses
			      for class = (find-bridge-class name)
			      collect class))
	  (remaining-keys (copy-list arguments)))
      (loop while (remf remaining-keys :direct-superclasses))
      (let ((result (apply #'cl:make-instance
			   'sicl-boot-phase1:built-in-class
			   :direct-default-initargs direct-default-initargs
			   :name name
			   :direct-superclasses superclasses
			   remaining-keys)))
	(add-bridge-class name result)
	;; FIXME: this is where we add create the accessors.
	result))))

Check if class already exists. Fix typo in keyword parameter.


(in-package :asdf-user)

(asdf:defsystem #:ql-scm
  :description "A Quicklisp extension that can pull from project SCMs directly."
  :version (:read-file-form "version.lisp-expr")
  :serial t
  :depends-on (#:quicklisp)
  :author "Eric Timmons <etimmons@mit.edu>"
  :license "MIT"
  :components ((:module "src"
                        :components
                        ((:file "package")
                         (:file "git")
                         (:file "scm-release")
                         (:file "scm-dist")
                         (:file "git-release")
                         (:file "ql-scm")))))

(in-package :asdf-user)

(asdf:defsystem #:ql-scm
  :description "A Quicklisp extension that can pull from project SCMs directly."
  :version (:read-file-form "version.lisp-expr")
  :serial t
  :depends-on (#:quicklisp
               (:feature (:not :asdf3) :uiop))
  :author "Eric Timmons <etimmons@mit.edu>"
  :license "MIT"
  :components ((:module "src"
                        :components
                        ((:file "package")
                         (:file "git")
                         (:file "scm-release")
                         (:file "scm-dist")
                         (:file "git-release")
                         (:file "ql-scm")))))

Make explicit the dependency on UIOP.

Make explicit the dependency on UIOP.


(in-package :rucksack)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Import/export
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The contents of a rucksack can be exported to a single file.  The file will
;; contain enough information to reconstruct the original rucksack objects.
;; Rucksack export files use a relatively simple s-expression format.
;;
;; There are two reasons for exporting a rucksack:
;; - backup
;;   The export file has a simple format, so it's a lot less sensitive
;;   to data corruption bugs.
;; - migration
;;   Export files can be imported by newer versions of Rucksack.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Import/export API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric export-rucksack (rucksack pathname)
  (:documentation "Export all objects in a rucksack to a file.  The
resulting file can be imported by newer versions of Rucksack."))

(defgeneric import-rucksack (pathname directory-designator
                             &rest args
                             &key (if-exists :error)
                             &allow-other-keys)
  (:documentation "Creates a new rucksack in the directory specified by
DIRECTORY-DESIGNATOR, opens the new rucksack and imports all objects
that were exported to the file specified by PATHNAME."))

(in-package :rucksack)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Import/export
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The contents of a rucksack can be exported to a single file.  The file will
;; contain enough information to reconstruct the original rucksack objects.
;; Rucksack export files use a relatively simple s-expression format.
;;
;; There are two reasons for exporting a rucksack:
;; - backup
;;   The export file has a simple format, so it's a lot less sensitive
;;   to data corruption bugs.
;; - migration
;;   Export files can be imported by newer versions of Rucksack.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Import/export API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric export-rucksack (rucksack pathname)
  (:documentation "Export all objects in a rucksack to a file.  The
resulting file can be imported by newer versions of Rucksack."))

(defun import-rucksack (pathname directory-designator
                        &rest args
                        &key (if-exists :error)
                        &allow-other-keys)
  "Creates a new rucksack in the directory specified by
DIRECTORY-DESIGNATOR, opens the new rucksack and imports all objects
that were exported to the file specified by PATHNAME."
  (declare (ignore pathname directory-designator if-exists args))
  (error "Not implemented yet"))

Change DEFGENERIC IMPORT-RUCKSACK to DEFUN IMPORT-RUCKSACK to fix a compiler warning reported by Brad Beveridge.


;;;; grok-arch-hexagonal.asd

;;; The MIT License (MIT)
;;;
;;; Copyright (c) 2016 Michael J. Forster
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in all
;;; copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(asdf:defsystem #:grok-arch-hexagonal
  :description "Grokking Alistair Cockburn's Hexagonal Architecture"
  :author "Michael J. Forster <mike@forsterfamily.ca>"
  :license "MIT"
  :depends-on (#:alexandria
               #:lisp-unit)
  :serial t
  :components ((:file "package")
               (:file "grok-arch-hexagonal")))

;;;; grok-arch-hexagonal.asd

;;; The MIT License (MIT)
;;;
;;; Copyright (c) 2016 Michael J. Forster
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in all
;;; copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(asdf:defsystem #:grok-arch-hexagonal
  :description "Grokking Alistair Cockburn's Hexagonal Architecture"
  :author "Michael J. Forster <mike@forsterfamily.ca>"
  :license "MIT"
  :depends-on (#:alexandria
               #:wu-decimal
               #:lisp-unit)
  :serial t
  :components ((:file "package")
               (:file "grok-arch-hexagonal")))

Add system dependency on wu-decimal

Add system dependency on wu-decimal


(import extra/term (colored))

(defun print-error! (msg)
  "Print an error messaage, MSG."
  (unless (string? msg) (set! msg (pretty msg)))
  (with (lines (string/split msg "\n" 1))
    (print! (colored 31 (.. "[ERROR] " (car lines))))
    (when (cadr lines) (print! (cadr lines)))))

(defun print-warning! (msg)
  "Print a warning message, MSG."
  (with (lines (string/split msg "\n" 1))
    (print! (colored 33 (.. "[WARN] " (car lines))))
    (when (cadr lines) (print! (cadr lines)))))

(defun print-verbose! (verbosity msg)
  "Print a verbose message, MSG if VERBOSITy is greater than 0."
  (when (> verbosity 0)
    (print! (.. "[VERBOSE] " msg))))

(defun print-debug! (verbosity msg)
  "Print a debug message, MSG if VERBOSITY is greater than 1."
  (when (> verbosity 1)
    (print! (.. "[DEBUG] " msg))))

(defun print-time! (maximum name time level)
  "Print the TIME NAME took to execute, if LEVEL is <= MAXIMIM."
  (when (<= level maximum)
    (print! (.. "[TIME] " name " took " time))))

(defun print-explain! (explain lines)
  "Put all LINES when explaining is enabled"
  (when explain
    (for-each line (string/split lines "\n")
      (print! (.. "  " line)))))

(import extra/term (colored))

(defun print-error! (msg)
  "Print an error messaage, MSG."
  (unless (string? msg) (set! msg (pretty msg)))
  (with (lines (string/split msg "\n" 1))
    (print! (colored 31 (.. "[ERROR] " (car lines))))
    (when (cadr lines) (print! (cadr lines)))))

(defun print-warning! (msg)
  "Print a warning message, MSG."
  (with (lines (string/split msg "\n" 1))
    (print! (colored 33 (.. "[WARN] " (car lines))))
    (when (cadr lines) (print! (cadr lines)))))

(defun print-verbose! (verbosity msg)
  "Print a verbose message, MSG if VERBOSITy is greater than 0."
  (when (> verbosity 0)
    (print! $"[VERBOSE] ~{msg}")))

(defun print-debug! (verbosity msg)
  "Print a debug message, MSG if VERBOSITY is greater than 1."
  (when (> verbosity 1)
    (print! $"[DEBUG] ~{msg}")))

(defun print-time! (maximum name time level)
  "Print the TIME NAME took to execute, if LEVEL is <= MAXIMIM."
  (when (<= level maximum)
    (print! $"[TIME] ~{name} took ~{time}")))

(defun print-explain! (explain lines)
  "Put all LINES when explaining is enabled"
  (when explain
    (for-each line (string/split lines "\n")
      (print! (.. "  " line)))))

Change to $ in a couple of places

Change to $ in a couple of places


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

;;;; The direct extrinsic compiler is a compiler that runs on some
;;;; host environment perhaps other than SICL.  It supplies a function
;;;; that compiles a single lambda expression in the null lexical
;;;; environment, and it produces a small graph of objects that can be
;;;; turned into target binary code in a straightforward way.

(defsystem :sicl-direct-extrinsic-compiler
  :depends-on (:sicl-extrinsic-environment
	       :cleavir-generate-ast
	       :cleavir-ast-to-hir
	       :sicl-hir-to-mir
	       :cleavir-hir-transformations
	       :cleavir-liveness
	       :cleavir-register-allocation)
  :serial t
  :components
  ((:file "packages")
   (:file "classes")
   (:file "introduce-immediates")
   (:file "process-constants")
   (:file "compile")))

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

;;;; The direct extrinsic compiler is a compiler that runs on some
;;;; host environment perhaps other than SICL.  It supplies a function
;;;; that compiles a single lambda expression in the null lexical
;;;; environment, and it produces a small graph of objects that can be
;;;; turned into target binary code in a straightforward way.

(defsystem :sicl-direct-extrinsic-compiler
  :depends-on (:sicl-extrinsic-environment
	       :cleavir-generate-ast
	       :cleavir-ast-to-hir
	       :sicl-hir-to-mir
	       :cleavir-hir-transformations
	       :cleavir-liveness
	       :cleavir-register-allocation)
  :serial t
  :components
  ((:file "packages")
   (:file "classes")
   (:file "process-constants")
   (:file "compile")))

Remove reference to non-existing component in system definition.


(in-package #:sys.int)

(define-condition unknown-coercion ()
  ((object :initarg :object
           :reader unknown-coercion-object)
   (type :initarg :type
         :reader unknown-coercion-type))
  (:report (lambda (condition stream)
             (format stream "Don't know how to coerce ~S to type ~S."
                     (unknown-coercion-object condition)
                     (unknown-coercion-type condition)))))

(defun coerce (object result-type)
  (when (or (eql result-type 't)
            (typep object result-type))
    (return-from coerce object))
  (cond ((subtypep result-type 'list)
         (map 'list 'identity object))
        ((subtypep result-type 'vector)
         (check-type object sequence)
         (let ((element-type (parse-array-type (typeexpand result-type))))
           (make-array (length object)
                       :element-type element-type
                       :initial-contents object)))
        (t (error 'unknown-coercion :object object :type result-type))))

(in-package #:sys.int)

(define-condition unknown-coercion ()
  ((object :initarg :object
           :reader unknown-coercion-object)
   (type :initarg :type
         :reader unknown-coercion-type))
  (:report (lambda (condition stream)
             (format stream "Don't know how to coerce ~S to type ~S."
                     (unknown-coercion-object condition)
                     (unknown-coercion-type condition)))))

(defun coerce (object result-type)
  (when (or (eql result-type 't)
            (typep object result-type))
    (return-from coerce object))
  (cond ((subtypep result-type 'list)
         (map 'list 'identity object))
        ((subtypep result-type 'vector)
         (check-type object sequence)
         (let ((element-type (parse-array-type (typeexpand result-type))))
           (make-array (length object)
                       :element-type element-type
                       :initial-contents object)))
        ((subtypep result-type 'float)
         (float object))
        (t (error 'unknown-coercion :object object :type result-type))))

Support coercing stuff to FLOAT.

Support coercing stuff to FLOAT.