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

(in-package :defrest-system)

(defsystem :defrest
  :description "defrest: expose functions as REST webservices for ajax or other stuff"
  :version "1"
  :author "Mathias Menzel-Nielsen <(reverse \"ed.tfosztam@eztam\")>" ;nospam
  :license "BSD"
  :depends-on (:hunchentoot
	       :cl-ppcre
	       :split-sequence)
  :in-order-to ((test-op (test-op "defrest.test")))
  :components ((:static-file "defrest.asd")
	       (:file "defrest")))

(defsystem :defrest.test
  :description "defrest Test Suite"
  :depends-on (:defrest :fiveam :drakma)
  :components ((:module :tests
		:components ((:file "suite")))))

(defmethod perform ((op test-op) (c (eql (find-system :defrest.test))))
  (funcall (intern (symbol-name '#:run!) :it.bese.FiveAM)))

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

(in-package :defrest-system)

(defsystem :defrest
  :description "defrest: expose functions as REST webservices for ajax or other stuff"
  :version "1"
  :author "Mathias Menzel-Nielsen <(reverse \"ed.tfosztam@eztam\")>" ;nospam
  :license "BSD"
  :depends-on (:hunchentoot
	       :cl-ppcre
	       :split-sequence)
  :in-order-to ((test-op (test-op "defrest.test")))
  :components ((:static-file "defrest.asd")
	       (:file "defrest")))

(defsystem :defrest.test
  :description "defrest Test Suite"
  :depends-on (:defrest :fiveam :drakma)
  :components ((:module :tests
		:components ((:file "suite")))))

(defmethod perform ((op test-op) (c (eql (find-system :defrest.test))))
  (funcall (intern (symbol-name '#:run-all-tests) :it.bese.FiveAM)))

Unit-Tests: Call run-all-tests instead of run! for upward compatibility with FiveAM v1.3


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

(asdf:defsystem :cleavir-ast-to-hir-test
  :depends-on (:cleavir-generate-ast-test
	       :cleavir-ast-to-hir
	       :cleavir-hir-interpreter)
  :serial t
  :components
  ((:file "packages")
   (:file "ast-to-hir")))

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

(defsystem :cleavir-ast-to-hir-test
  :depends-on (:cleavir-generate-ast-test
	       :cleavir-ast-to-hir
	       :cleavir-hir-interpreter)
  :serial t
  :components
  ((:file "packages")
   (:file "ast-to-hir")))

Define ASDF system in package ASDF-USER.


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

(define-condition binary-tree-error (error acclimation:condition)
  ())

(define-condition invalid-binary-tree (binary-tree-error)
  ())

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

(define-condition binary-tree-error (error acclimation:condition)
  ())

(define-condition invalid-binary-tree (binary-tree-error)
  ((%tree :initarg :tree :reader tree)))

Add slot TREE to condition INVALID-BINARY-TREE.


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

(defgeneric replace-child (node old-child new-child))

(defmethod replace-child ((node null) (old-child node) new-child)
  new-child)

Add method on REPLACE-CHILD specialized to a NULL node.


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

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

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

Define generic function for determining whether an instruction can be removed.


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

(asdf:defsystem :cleavir-basic-blocks
  :depends-on (:cleavir-utilities
	       :cleavir-hir)
  :components
  ((:file "packages")
   (:file "basic-blocks" :depends-on ("packages"))))

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

(defsystem :cleavir-basic-blocks
  :depends-on (:cleavir-utilities
	       :cleavir-hir)
  :components
  ((:file "packages")
   (:file "basic-blocks" :depends-on ("packages"))))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


(define-filter make-keywords (x)
  (make-keyword x))

(fn make-keyword (x)
  (& x
     (make-symbol (? (symbol? x)
                     (symbol-name x)
                     x)
                  "KEYWORD")))

(define-filter make-keywords (x)
  (make-keyword x))

(fn make-keyword (x)
  (& x
     (make-symbol (? (symbol? x)
                     (symbol-name x)
                     x)
                  *keyword-package*)))

Use *KEYWORD-PACKAGE* instead of "KEYWORD" with MAKE-SYMBOL.


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

(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)
    (when (eql char #\Newline)
      (setf (column stream) 0)
      (incf (line stream)))
    char))

Put code in specific package.

Put code in specific package.


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

(defsystem cl-acronyms
  :name "Acronym Expander"
  :author "Isoraķatheð Zorethan <isoraqathedh.zorethan@gmail.com>"
  :maintainer "Isoraķatheð Zorethan <isoraqathedh.zorethan@gmail.com>"
  :version "1.0.0"
  :licence "MIT"
  :description "A program that expands an acronym based on grammatical rules."
  :serial t
  :components ((:file "cl-acronyms")))

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

(defsystem cl-acronyms
  :name "Acronym Expander"
  :author "Isoraķatheð Zorethan <isoraqathedh.zorethan@gmail.com>"
  :maintainer "Isoraķatheð Zorethan <isoraqathedh.zorethan@gmail.com>"
  :version "1.0.0"
  :licence "MIT"
  :description "A program that expands an acronym based on grammatical rules."
  :serial t
  :components ((:file "cl-acronyms"))
  :depends-on (:alexandria))

Add alexandria as a dependency.

Add alexandria as a dependency.


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

(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))
  (if (null (char-to-read 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)
      (prog1 (char-to-read stream)
	(setf (char-to-read stream) nil))))

Return the unread char if it is non-NIL.


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

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

(defclass always-clause (termination-test-clause)
  ((%form :initarg :form :reader form)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser always-clause-parser
  (consecutive (lambda (always form)
		 (declare (ignore always))
		 (make-instance 'always-clause
		   :form form))
	       (keyword-parser 'always)
	       'anything-parser))

(add-clause-parser 'always-clause-parser)

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

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

(defclass always-clause (termination-test-clause form-mixin)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser always-clause-parser
  (consecutive (lambda (always form)
		 (declare (ignore always))
		 (make-instance 'always-clause
		   :form form))
	       (keyword-parser 'always)
	       'anything-parser))

(add-clause-parser 'always-clause-parser)

Use existing FORM-MIXIN class as a superclass.


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

(asdf:defsystem :sicl-cons-package
  :serial t
  :components
  ((:file "packages")))

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

(defsystem :sicl-cons-package
  :serial t
  :components
  ((:file "packages")))


(when (asdf:find-system :local-time nil) (pushnew :js-dates *features*))

(asdf:defsystem :cl-js
  :description "JavaScript-to-CL compiler and runtime"
  :depends-on (:parse-js :cl-ppcre #+js-dates :local-time)
  :serial t
  :components
  ((:file "package")
   (:file "utils")
   (:file "js")
   (:file "jsos")
   (:file "url-encode")
   (:file "json")
   (:file "deflib")
   (:file "runtime")
   (:file "infer")
   (:file "inline-op")
   (:file "translate")
   (:file "operators")
   (:file "api")))

(when (asdf:find-system :local-time nil) (pushnew :js-dates *features*))

(asdf:defsystem :cl-js
  :description "JavaScript-to-CL compiler and runtime"
  :author "Marijn Haverbeke <marijnh@gmail.com>"
  :license "MIT"
  :depends-on (:parse-js :cl-ppcre #+js-dates :local-time)
  :serial t
  :components
  ((:file "package")
   (:file "utils")
   (:file "js")
   (:file "jsos")
   (:file "url-encode")
   (:file "json")
   (:file "deflib")
   (:file "runtime")
   (:file "infer")
   (:file "inline-op")
   (:file "translate")
   (:file "operators")
   (:file "api")))

Add :author/:license to ASD file

Add :author/:license to ASD file

Closes #26


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

(defmethod cleavir-i18n:report-condition
    ((condition unmatched-right-parenthesis)
     stream
     (language cleavir-i18n:english))
  (format stream "Unmatched right parenthesis found."))

(defmethod cleavir-i18n:report-condition
    ((condition only-dots-in-token)
     stream
     (language cleavir-i18n:english))
  (format stream "A token with only dots in it was found"))

(defmethod cleavir-i18n:report-condition
    ((condition single-dot-token)
     stream
     (language cleavir-i18n:english))
  (format stream "A token consisting of a single dot was found ~@
                  in a context that does not permit such a token."))

(defmethod cleavir-i18n:report-condition
    ((condition no-object-preceding-dot)
     stream
     (language cleavir-i18n:english))
  (format stream "A left parenthesis cannot be ~
                  immediately followed by a dot"))

Add method on REPORT-CONDITION specialized to NO-OBJECT-PRECEDING-DOT.


(defpackage #:local-time.system
  (:use :common-lisp :asdf))

(in-package #:local-time.system)

(defsystem :local-time
  :name "local-time"
  :version "0.9.1"
  :author "Daniel Lowe <dlowe@sanctuary.org>"
  :description "A library for manipulating dates and times, based on a paper by Erik Naggum"
  :components ((:file "local-time")))

(defsystem #:local-time.test
  :name "local-time.test"
  :version "0.9.1"
  :author "Daniel Lowe <dlowe@sanctuary.org>"
  :description "Testing code for the local-time library"
  :depends-on (:local-time :fiveam)
  :components ((:file "tests")))

(defmethod perform ((op test-op) (system (eql (find-system :local-time))))
  (operate 'load-op '#:local-time.test)
  (funcall (read-from-string "local-time::run-tests")))

;; this is not really nice to have it enabled by default
#+nil(defmethod perform :after ((op load-op) (system (eql (find-system :local-time))))
  (in-package :local-time))

(defmethod operation-done-p ((op test-op) (system (eql (find-system :local-time))))
  nil)

(defpackage #:local-time.system
  (:use :common-lisp :asdf))

(in-package #:local-time.system)

(defsystem :local-time
  :name "local-time"
  :version "0.9.1"
  :author "Daniel Lowe <dlowe@sanctuary.org>"
  :description "A library for manipulating dates and times, based on a paper by Erik Naggum"
  :components ((:file "local-time")))

(defsystem #:local-time.test
  :name "local-time.test"
  :version "0.9.1"
  :author "Daniel Lowe <dlowe@sanctuary.org>"
  :description "Testing code for the local-time library"
  :depends-on (:local-time :fiveam)
  :components ((:file "tests")))

(defmethod perform ((op test-op) (system (eql (find-system :local-time))))
  (operate 'load-op '#:local-time.test)
  (funcall (read-from-string "5am:run!")))

(defmethod operation-done-p ((op test-op) (system (eql (find-system :local-time))))
  nil)

Enable running 5am tests by default

Enable running 5am tests by default


; tré – Copyright (c) 2014–2015 Sven Michael Klose <pixel@hugbox.org>

(defbuiltin not (&rest x) (cl:every #'cl:not x))
(defbuiltin builtin? (x)  (cl:gethash x *builtins*))

(defun variable-compare (predicate x)
  (? .x
     (alet x.
       (@ (i .x t)
         (| (funcall predicate ! i)
            (return nil))))
     (cl:error "At least 2 arguments required.")))

(defun non-keyword-symbol? (x)
  (& (cl:symbolp x)
     (cl:not (cl:keywordp x))))

(defun xpackeq (a b)
  (? (& (non-keyword-symbol? a)
        (non-keyword-symbol? b))
     (cl:string= (cl:symbol-name a)
                 (cl:symbol-name b))
     (cl:eq a b)))

(defun tre-eql (a b)
  (?
    (& (number? a)
       (number? b))  (? (cl:eq (character? a)
                               (character? b))
                        (== a b))
    (& (cons? a)
       (cons? b))    (& (tre-eql a. b.)
                        (tre-eql .a .b))
    (xpackeq a b)))

(defbuiltin eq (&rest x)  (variable-compare #'xpackeq x))
(defbuiltin eql (&rest x) (variable-compare #'tre-eql x))

; tré – Copyright (c) 2014–2015 Sven Michael Klose <pixel@hugbox.org>

(defbuiltin not (&rest x) (cl:every #'cl:not x))
(defbuiltin builtin? (x)  (cl:gethash x *builtins*))

(defun variable-compare (predicate x)
  (? .x
     (@ (i .x t)
       (| (funcall predicate x. i)
          (return nil)))
     (cl:error "At least 2 arguments required.")))

(defun non-keyword-symbol? (x)
  (& (cl:symbolp x)
     (cl:not (cl:keywordp x))))

(defun xpackeq (a b)
  (? (& (non-keyword-symbol? a)
        (non-keyword-symbol? b))
     (cl:string= (cl:symbol-name a)
                 (cl:symbol-name b))
     (cl:eq a b)))

(defun tre-eql (a b)
  (?
    (& (number? a)
       (number? b))   (& (cl:eq (cl:characterp a)
                                (cl:characterp b))
                         (== a b))
    (& (cl:consp a)
       (cl:consp b))  (& (tre-eql a. b.)
                         (tre-eql .a .b))
    (xpackeq a b)))

(defbuiltin eq (&rest x)  (variable-compare #'xpackeq x))
(defbuiltin eql (&rest x) (variable-compare #'tre-eql x))

Use CL functions where possible.

Use CL functions where possible.


;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- ASDF system definition.
;;;

(asdf:defsystem :io.zeta-streams
  :description "Zeta streams."
  :maintainer "Stelian Ionescu <sionescu@common-lisp.net>"
  :licence "MIT"
  :depends-on (:iolib.base :iolib.syscalls :cffi :bordeaux-threads)
  :pathname (merge-pathnames #p"io.streams/zeta/" *load-truename*)
  :components
  ((:file "pkgdcl")
   (:file "types" :depends-on ("pkgdcl"))
   (:file "conditions" :depends-on ("pkgdcl"))

   ;; Platform-specific files
   (:file "ffi-functions"
     :pathname #+unix "ffi-functions-unix"
     :depends-on ("pkgdcl" "conditions"))

   ;; Device interface definition
   (:file "device" :depends-on ("pkgdcl" "types"))

   ;; Low-level buffers
   (:file "iobuf" :depends-on ("pkgdcl" "types"))

   ;; Streams
   (:file "stream" :depends-on ("pkgdcl" "types" "conditions" "device" "iobuf"))

   ;; Devices
   (:file "file"
     :pathname #+unix "file-unix"
     :depends-on ("pkgdcl" "types" "conditions" "ffi-functions" "device" "stream"))))

;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- ASDF system definition.
;;;

(asdf:defsystem :io.zeta-streams
  :description "Zeta streams."
  :maintainer "Stelian Ionescu <sionescu@common-lisp.net>"
  :licence "MIT"
  :depends-on (:iolib.base :iolib.syscalls :iolib.pathnames :cffi :bordeaux-threads)
  :pathname (merge-pathnames #p"io.streams/zeta/" *load-truename*)
  :components
  ((:file "pkgdcl")
   (:file "types" :depends-on ("pkgdcl"))
   (:file "conditions" :depends-on ("pkgdcl"))

   ;; Platform-specific files
   (:file "ffi-functions"
     :pathname #+unix "ffi-functions-unix"
     :depends-on ("pkgdcl" "conditions"))

   ;; Device interface definition
   (:file "device" :depends-on ("pkgdcl" "types"))

   ;; Low-level buffers
   (:file "iobuf" :depends-on ("pkgdcl" "types"))

   ;; Streams
   (:file "stream" :depends-on ("pkgdcl" "types" "conditions" "device" "iobuf"))

   ;; Devices
   (:file "file"
     :pathname #+unix "file-unix"
     :depends-on ("pkgdcl" "types" "conditions" "ffi-functions" "device" "stream"))))

Add dependency on IOLIB.PATHNAMES to IO.ZETA-STREAMS .


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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Macro LAMBDA.

(defmacro lambda (lambda-list &body body)
  `(function (lambda ,lambda-list ,@body)))

(cl:in-package #:sicl-evaluation-and-compilation)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Macro LAMBDA.

(defmacro lambda (lambda-list &body body)
  `(function (lambda ,lambda-list ,@body)))

Put the LAMBDA macro in the package where it belongs.


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

;;;  (c) copyright 2008 by
;;;           Troels Henriksen (athas@sigkill.dk)
;;;
;;; 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-jpeg-bitmaps
  :description "Support for JPEG images in McCLIM bitmap reading functions."
  :depends-on (:mcclim :cl-jpeg)
  :components ((:file "jpeg" :pathname #P"Extensions/Bitmap-formats/jpeg")))

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

;;;  (c) copyright 2008 by
;;;           Troels Henriksen (athas@sigkill.dk)
;;;
;;; 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-jpeg-bitmaps
  :description "Support for JPEG images in McCLIM bitmap reading functions."
  :depends-on (:mcclim :cl-jpeg)
  :components ((:file "jpeg" :pathname #P"Extensions/Bitmap-formats/jpeg")))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


(in-package :website)

;;;

(defwidget header (on-demand-selector)
  ((default-title :accessor header-default-title
                  :initarg :default-title
                  :type string
                  :initform "")
   (title-fn :accessor header-title-fn
             :type function
             :initarg :title-fn)))

(defmethod initialize-instance :after ((header header) &key &allow-other-keys)
  (setf (on-demand-lookup-function header)
        (lambda (header tokens)
          (let ((title nil))
            (if (null tokens)
                (setf title (funcall (header-title-fn header) (header-default-title header)))
                (setf title (or (funcall (header-title-fn header) (first tokens))
                                (header-default-title header))))
            (values (make-widget
                     (f_% (with-html
                            (:div :style "display:table"
                             (:div :style "display:table-cell;width:100%"
                              (:h1 (:div :class "mainheader" (str title))))
                             (:div :style "display:table-cell;"
                                (:a :href "http://weblocks.viridian-project.de/"
                                    (:img :src (make-webapp-public-file-uri "images/weblocks-alien-small.png")
                                          :alt "Made with Weblocks"
                                          :style "vertical-align:middle")))))))
                    nil
                    tokens
                    :no-cache)))))

;;;

nil

(in-package :website)

;;;

(defwidget header (on-demand-selector)
  ((default-title :accessor header-default-title
                  :initarg :default-title
                  :type string
                  :initform "")
   (title-fn :accessor header-title-fn
             :type function
             :initarg :title-fn)))

(defmethod initialize-instance :after ((header header) &key &allow-other-keys)
  (setf (on-demand-lookup-function header)
        (lambda (header tokens)
          (let ((title nil))
            (if (null tokens)
                (setf title (funcall (header-title-fn header) (header-default-title header)))
                (setf title (or (funcall (header-title-fn header) (first tokens))
                                (header-default-title header))))
            (values (make-widget
                     (f_% (with-html
                            (:div :style "display:table"
                             (:div :style "display:table-cell;width:100%"
                              (:h1 (:div :class "mainheader" (str title))))
                             (:div :style "display:table-cell;"
                                (:a :href "http://weblocks-framework.info/"
                                    (:img :src (make-webapp-public-file-uri "images/weblocks-alien-small.png")
                                          :alt "Made with Weblocks"
                                          :style "vertical-align:middle")))))))
                    nil
                    tokens
                    :no-cache)))))

;;;

nil

Update link to weblocks project

Update link to weblocks project

Signed-off-by: Daniel Borchmann <25857343a15bf1edafebc2912e82ecf775c585c1@mailbox.tu-dresden.de>


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

(asdf:defsystem :cleavir-environment
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "query")
   (:file "augmentation-functions")
   (:file "default-augmentation-classes")
   (:file "default-info-methods")
   (:file "eval")))

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

(asdf:defsystem :cleavir-environment
  :depends-on (:cleavir-internationalization)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "query")
   (:file "augmentation-functions")
   (:file "default-augmentation-classes")
   (:file "default-info-methods")
   (:file "eval")))

Make the system depend on the internationalization system.


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

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

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

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

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

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

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

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

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

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

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

Add variable for target operating system.


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

(in-package :glkit.asdf)

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

  :depends-on (:sdl2kit-examples :glkit)
  :pathname "examples"
  :serial t

  :components
  ((:file "package")
   (:file "vaos")
   (:file "vao-shader-window")
   (:file "vao-shader-330")
   (:file "vao-shader-150")
   (:file "vao-shader-120")))

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

(in-package :glkit.asdf)

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

  :depends-on (:sdl2kit-examples :glkit)
  :pathname "examples"
  :serial t

  :components
  ((:file "package")
   (:file "vaos")
   (:file "vao-shader-window")
   (:file "vao-shader-410")
   (:file "vao-shader-330")
   (:file "vao-shader-150")
   (:file "vao-shader-120")))

Add 410 example to asd

Add 410 example to asd


(in-package :6502)

(defparameter *benchmark*
  (asm " ;; Clear the Decimal and Carry status bits
         CLD
         CLC
         ;; Set the Accumulator and X and Y regs to zero
         LDA #$00
         LDX #$00
         LDY #$00
         ;; Increment Y until it wraps around to zero, then proceed to 0x0b
         loop:
         INY
         BNE &loop
         ;; subtract the sum of value at 0x01+carry from accumulator and halt.
         ;; (remember that absolute addresses are stored low-byte first)
         SBC $0001
         BRK")
  "Should leave the Accumulator with the value 231.")

; After (setf (get-range 0) *nop-loop*) do...
; (time (loop until (> (cpu-cc *cpu*) 1800000) do (6502-step *cpu* (zero-page *cpu*))))
; Maybe (require 'sb-sprof) (with-profiling (:max-samples 1000 :report :flat :show-progress t) ...)
(defparameter *nop-loop*
  (asm "loop:
          nop
          jmp $loop")
  "Do nothing forever.")

; Thanks to Ed Spittles for his wisdom and assistance
(defun klaus-test ()
  "Run Klaus' functional testsuite."
  (6502::load-binary "projects/cl-6502/tests/6502_functional_test.bin")
  (setf (cpu-pc *cpu*) #x1000)
  (execute *cpu*))

(in-package :6502)

(defparameter *benchmark*
  (asm " ;; Clear the Carry status bit
         CLC
         ;; Set the Accumulator and X and Y regs to zero
         LDA #$00
         LDX #$00
         LDY #$00
         ;; Increment Y until it wraps around to zero, then proceed to 0x0b
         loop:
         INY
         BNE &loop
         ;; subtract the sum of value at 0x01+carry from accumulator and halt.
         ;; (remember that absolute addresses are stored low-byte first)
         SBC $0001
         BRK")
  "Should leave the Accumulator with the value 231.")

; After (setf (get-range 0) *nop-loop*) do...
; (time (loop until (> (cpu-cc *cpu*) 1800000) do (6502-step *cpu* (zero-page *cpu*))))
; Maybe (require 'sb-sprof) (with-profiling (:max-samples 1000 :report :flat :show-progress t) ...)
(defparameter *nop-loop*
  (asm "loop:
          nop
          jmp $loop")
  "Do nothing forever.")

; Thanks to Ed Spittles for his wisdom and assistance
(defun klaus-test ()
  "Run Klaus' functional testsuite."
  (6502::load-binary "projects/cl-6502/tests/6502_functional_test.bin")
  (setf (cpu-pc *cpu*) #x1000)
  (execute *cpu*))

Remove extraneous CLD from example.

Remove extraneous CLD from example.


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

(setf (documentation 'left 'function)
      (format nil "Given a binary tree, return the left child of that tree.~@
                   If an object other than a binary tree is given,~@
                   then an error of type INVALID-BINARY-TREE is signaled."))

(setf (documentation 'right 'function)
      (format nil "Given a binary tree, return the right child of that tree.~@
                   If an object other than a binary tree is given,~@
                   then an error of type INVALID-BINARY-TREE is signaled."))

(setf (documentation '(setf left) 'function)
      (format nil "Given two binary trees, NEW and TREE,~@
                   make NEW the new left child of TREE.~@
                   NEW may be a node or NIL.~@
                   If TREE is NIL an error of type,~@
                   INVALID-BINARY-TREE is signaled."))

(setf (documentation '(setf right) 'function)
      (format nil "Given two binary trees, NEW and TREE,~@
                   make NEW the new right child of TREE.~@
                   NEW may be a node or NIL.~@
                   If TREE is NIL an error of type,~@
                   INVALID-BINARY-TREE is signaled."))

(setf (documentation 'rotate-left 'function)
      (format nil "Given a binary tree TREE, apply a left rotation to it.~@
                   If TREE is not a node, an error of type,~@
                   INVALID-BINARY-TREE is signaled.~@
                   If the right child of TREE is not a node, an error of type~@
                   RIGHT-SUBTREE-MUST-BE-NON-NIL is signaled.~@
                   The new root of the tree is returned.~@
                   If TREE has a parent node, no provision is made~@
                   for replacing TREE with the return value of this function.~@
                   Client code is responsible for doing that."))

Add English documentation for function ROTATE-LEFT.


;;;;; tré - Copyright (c) 2005-2006,2008,2010-2012 Sven Michael Klose <pixel@copei.de>

;; Create new local variable.
(defmacro let (place expr &body body)
  (?
	(not body)
	  (progn
		(print place)
		(print expr)
		(print body)
	    (%error "body expected"))
    (cons? place)
	  (%error "place is not an atom")
      `(#'((,place)
			  ,@body) ,expr)))

;;;;; tré – Copyright (c) 2005-2006,2008,2010–2012 Sven Michael Klose <pixel@copei.de>

;; Create new local variable.
(defmacro let (place expr &body body)
  (?
	(not body)
	  (progn
		(print place)
		(print expr)
		(print body)
	    (%error "body expected"))
    (cons? place)
	  (progn
        (print place)
	    (%error "place is not an atom"))
    `(#'((,place)
          ,@body) ,expr)))

Print place if it's not an atom.

Print place if it's not an atom.


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

(defclass environment (sicl-simple-environment:simple-environment)
  ())

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

(defclass environment (sicl-extrinsic-environment:environment)
  ())

Make the extrinsic environment a superclass.


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

(defgeneric iterative-traversal (tree enter))

(defmethod iterative-traversal ((tree node-with-parent) enter leave)
  (let ((current-node tree))
    (loop do (if (or (not (funcall enter current-node))
		     (and (null (left current-node))
			  (null (right current-node))))
		 (loop for parent = (parent current-node)
		       until (or (null parent)
				 (and (eq current-node (left parent))
				      (not (null (right parent)))))
		       do (funcall leave current-node)
			  (setf current-node parent)
		       finally (if (null parent)
				   (return-from iterative-traversal)
				   (setf current-node (right parent))))
		 (setf current-node
		       (or (left current-node)
			   (right current-node)))))))

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

(defgeneric iterative-traversal (tree enter leave))

(defmethod iterative-traversal ((tree node-with-parent) enter leave)
  (let ((current-node tree))
    (loop do (if (or (not (funcall enter current-node))
		     (and (null (left current-node))
			  (null (right current-node))))
		 (loop for parent = (parent current-node)
		       until (or (null parent)
				 (and (eq current-node (left parent))
				      (not (null (right parent)))))
		       do (funcall leave current-node)
			  (setf current-node parent)
		       finally (if (null parent)
				   (return-from iterative-traversal)
				   (setf current-node (right parent))))
		 (setf current-node
		       (or (left current-node)
			   (right current-node)))))))

Add new parameter to generic function definition.


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

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

(defun define-allocate-general-instance (env)
  (setf (sicl-genv:fdefinition 'sicl-clos:allocate-general-instance env)
	(lambda (class size)
	  (make-instance 'header
	    :class class
	    :rack (make-array size)))))

(defun phase3 ()
  (let ((r2 *phase2-mop-class-env*)
	(r3 *phase2-mop-accessor-env*))
    (message "Start of phase 3~%")
    (ld "../CLOS/class-finalization-support.lisp" r2 r2)
    (ld "../CLOS/class-finalization-defuns.lisp" r2 r2)
    (define-allocate-general-instance r3)
    (message "End of phase 3~%")))

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

(defun define-effective-slot-definition-class-phase3 (env1 env2)
  (setf (sicl-genv:fdefinition 'sicl-clos:effective-slot-definition-class
			       env1)
	(lambda (&rest args)
	  (declare (ignore args))
	  (sicl-genv:find-class 'sicl-clos:standard-effective-slot-definition
				env2))))

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

(defun define-allocate-general-instance (env)
  (setf (sicl-genv:fdefinition 'sicl-clos:allocate-general-instance env)
	(lambda (class size)
	  (make-instance 'header
	    :class class
	    :rack (make-array size)))))

(defun phase3 ()
  (let ((r2 *phase2-mop-class-env*)
	(r3 *phase2-mop-accessor-env*))
    (message "Start of phase 3~%")
    (ld "../CLOS/class-finalization-support.lisp" r2 r2)
    (ld "../CLOS/class-finalization-defuns.lisp" r2 r2)
    (define-effective-slot-definition-class-phase3 r2 r2)
    (define-allocate-general-instance r3)
    (message "End of phase 3~%")))

Define EFFECTIVE-SLOT-DEFINITION-CLASS in phase 3.


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

(defun import-from-sicl-global-environment (environment)
  (setf (sicl-env:special-variable 'sicl-env:*global-environment* environment t)
	environment))

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

(defun import-from-sicl-global-environment (environment)
  ;; This variable is deprecated.  Uses of it should be replaced by
  ;; uses of the constant sicl-env:+global-environment+
  (setf (sicl-env:special-variable 'sicl-env:*global-environment* environment t)
	environment)
  (setf (sicl-env:constant-variable 'sicl-env:+global-environment+ environment)
	environment))

Create new constant variable in addition to existing special variable.


;;;;; tré – Copyright (c) 2005–2009,2011–2012 Sven Michael Klose <pixel@copei.de>

(defun %compiled-atom (x quoted?)
  (? (& quoted? x (symbol? x))
     (list 'quote x)
     x))

(defun compiled-list (x &key (quoted? nil))
  (? (cons? x)
     `(cons ,(%compiled-atom x. quoted?)
            ,(compiled-list .x :quoted? quoted?))
	 (%compiled-atom x quoted?)))

(defun compiled-tree (x &key (quoted? nil))
  (? (cons? x)
     `(cons ,(compiled-tree x. :quoted? quoted?)
            ,(compiled-tree .x :quoted? quoted?))
	 (%compiled-atom x quoted?)))

;;;;; tré – Copyright (c) 2005–2009,2011–2012 Sven Michael Klose <pixel@copei.de>

(defun %compiled-atom (x quoted?)
  (? (& quoted? x (symbol? x))
     (list 'quote x)
     x))

(defun compiled-list (x &key (quoted? nil))
  (? (cons? x)
     `(%%%cons ,(%compiled-atom x. quoted?)
               ,(compiled-list .x :quoted? quoted?))
	 (%compiled-atom x quoted?)))

(defun compiled-tree (x &key (quoted? nil))
  (? (cons? x)
     `(%%%cons ,(compiled-tree x. :quoted? quoted?)
               ,(compiled-tree .x :quoted? quoted?))
	 (%compiled-atom x quoted?)))

Use %%%CONS instead of CONS to work around infinite loops due to argument expansions.


(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-type:typep environment)
  (ld "../../Types/typep.lisp" 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))

(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-type:typep environment)
  (ld "../../Types/typep.lisp" 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/defclass-support.lisp" environment))

Load a file containing support code for DEFCLASS.


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

(defun car (list)
  (declare (type list list))
  (if (consp list)
      (cleavir-primop:car list)
      nil))

(defun cdr (list)
  (declare (type list list))
  (if (consp list)
      (cleavir-primop:cdr list)
      nil))

(defun rplaca (cons object)
  (declare (type cons cons))
  (cleavir-primop:rplaca cons object)
  cons)

(defun rplacd (cons object)
  (declare (type cons cons))
  (cleavir-primop:rplacd cons object)
  cons)

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

(defun car (list)
  (if (consp list)
      (cleavir-primop:car list)
      (if (null list)
	  nil
	  (error 'must-be-list :datum list))))

(defun cdr (list)
  (if (consp list)
      (cleavir-primop:cdr list)
      (if (null list)
	  nil
	  (error 'must-be-list :datum list))))

(defun rplaca (cons object)
  (if (consp list)
      (progn (cleavir-primop:rplaca cons object) cons)
      (error 'must-be-cons cons)))

(defun rplacd (cons object)
  (if (consp list)
      (progn (cleavir-primop:rplacd cons object) cons)
      (error 'must-be-cons cons)))

Use explicit test for type of argument.

Use explicit test for type of argument.


(cl:in-package #:cleavir-dataflow-analysis)

(defclass operation ()
  ((%instruction :initarg :instruction :reader instruction)
   (%inputs :initform '() :initarg inputs :accessor inputs)
   (%outputs :initform '() :initarg outputs :accessor outputs)))

(defclass dataflow ()
  ((%operations :initarg :operations :accessor operations)))

Define class for result of analysis.

Define class for result of analysis.


;;;;; tré – Copyright (c) 2005–2008,2010–2012 Sven Michael Klose <pixel@copei.de>

(defmacro do (binds (test &rest result) &body body)
  (let tag (gensym)
    `(block nil
       (let* ,(mapcar #'((b)
						  `(,(car b) ,(cadr b)))
					 binds)
         (tagbody
           ,tag
           (? ,test
              (return (progn ,@result)))
           ,@body
           ,@(mapcar #'((b)
						  (& (caddr b)
						     `(setq ,(car b) ,(caddr b))))
					 binds)
           (go ,tag))))))

(defmacro dotimes ((iter times &rest result) &body body)
  (let g (gensym)
    `(let ,g ,times
       (do ((,iter 0 (integer+ 1 ,iter)))
	       ((integer== ,iter ,times) ,@result)
	     ,@body))))

(defmacro dotimes-step ((iter times step &rest result) &body body)
  `(do ((,iter 0 (integer+ ,step ,iter)))
	   ((not (integer< ,iter ,times)) ,@result)
	 ,@body))

;;;;; tré – Copyright (c) 2005–2008,2010–2012 Sven Michael Klose <pixel@copei.de>

(defmacro do (binds (test &rest result) &body body)
  (let tag (gensym)
    `(block nil
       (let* ,(mapcar #'((b)
						  `(,(car b) ,(cadr b)))
					 binds)
         (tagbody
           ,tag
           (? ,test
              (return (progn ,@result)))
           ,@body
           ,@(mapcar #'((b)
						  (& (caddr b)
						     `(setq ,(car b) ,(caddr b))))
					 binds)
           (go ,tag))))))

(defmacro dotimes ((iter times &rest result) &body body)
  (let g (gensym)
    `(let ,g (integer ,times)
       (do ((,iter 0 (integer+ 1 ,iter)))
	       ((integer== ,iter ,g) ,@result)
	     ,@body))))

(defmacro dotimes-step ((iter times step &rest result) &body body)
  `(do ((,iter 0 (integer+ ,step ,iter)))
	   ((not (integer< ,iter ,times)) ,@result)
	 ,@body))

Make integer of number of times.

DOTIMES: Make integer of number of times.


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

(defsystem :sicl-sequences
  :depends-on (:lisp-unit)
  :serial t
  :components
  ((:file "packages")
   (:file "common")
   (:file "sequences")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))

(defsystem :sicl-sequences-tiny
  :depends-on (:lisp-unit)
  :serial t
  :components
  ((:file "packages")
   (:file "common")
   (:file "Tiny/sequences-tiny")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))

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

(defsystem :sicl-sequences
  :depends-on (:lisp-unit)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "sequences")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))

(defsystem :sicl-sequences-tiny
  :depends-on (:lisp-unit)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "Tiny/sequences-tiny")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))

Use new component name in system definitions.


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

(defun reassignment? (fi x)
  (and (%setq? x)
       (funinfo-in-args-or-env? fi (%setq-place x))))

(defun metacode-splitpoint? (statements)
  (or (vm-jump? x.)
      (number? .x.)
      (reassignment? fi x.)))

(defun copy-until-cblock-end (cb fi x)
  (let result (make-queue)
    (while (and x (not (metacode-splitpoint? x)))
           (progn
             (when (reassignment? fi x.)
               (adjoin! (%setq-place x.) (cblock-merged-ins cb)))
             (values (append (queue-list result)
                             (when x
                               (list x.)))
                     .x))
      (enqueue result (copy-tree x.))
      (setf x .x))))

(defun metacode-to-cblocks-0 (fi x)
  (when x
    (let cb (make-cblock)
      (with ((copy next) (copy-until-cblock-end cb fi x))
        (setf (cblock-code cb) copy)
        (cons cb (metacode-to-cblocks-0 fi next))))))

(defun metacode-to-cblocks (x fi)
  (append (list (make-cblock :ins (funinfo-args fi)))
          (metacode-to-cblocks-0 fi x)
          (list (make-cblock :ins (list '~%ret)))))

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

(defun reassignment? (fi x)
  (and (%setq? x)
       (funinfo-in-args-or-env? fi (%setq-place x))))

(defun metacode-splitpoint? (fi x)
  (or (vm-jump? x.)
      (number? .x.)
      (reassignment? fi x.)))

(defun copy-until-cblock-end (cb fi x)
  (let result (make-queue)
    (while (and x (not (metacode-splitpoint? fi x)))
           (progn
             (when (reassignment? fi x.)
               (adjoin! (%setq-place x.) (cblock-merged-ins cb)))
             (values (append (queue-list result)
                             (when x
                               (list x.)))
                     .x))
      (enqueue result (copy-tree x.))
      (setf x .x))))

(defun metacode-to-cblocks-0 (fi x)
  (when x
    (let cb (make-cblock)
      (with ((copy next) (copy-until-cblock-end cb fi x))
        (setf (cblock-code cb) copy)
        (cons cb (metacode-to-cblocks-0 fi next))))))

(defun metacode-to-cblocks (x fi)
  (append (list (make-cblock :ins (funinfo-args fi)))
          (metacode-to-cblocks-0 fi x)
          (list (make-cblock :ins (list '~%ret)))))

Fix arguments in some call.

Fix arguments in some call.


;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
;;;; SPDX-License-Identifier: BSD-3-Clause

(in-package :nyxt)

(export-always '*yes-no-choices*)
(defparameter *yes-no-choices* '(:yes "yes" :no "no")
  "The suggestions when asking the user for a yes/no choice.
See `if-confirm'.
The first suggestion poses as a default.")

(defun yes-no-suggestion-filter ()
  (lambda (minibuffer)
    (fuzzy-match (input-buffer minibuffer) (sera:plist-values *yes-no-choices*))))

(defun confirmed-p (answer)
  (string-equal answer (getf *yes-no-choices* :yes)))

(export-always 'if-confirm)
(defmacro if-confirm (prompt yes-form &optional no-form)
  "Ask the user for confirmation before executing either YES-FORM of NO-FORM.
YES-FORM is executed on  \"yes\" answer, NO-FORM -- on \"no\".
PROMPT is a list fed to `format nil'.

Example usage defaulting to \"no\":

\(let ((*yes-no-choices* '(:no \"no\" :yes \"yes\")))
  (if-confirm (\"Are you sure to kill ~a buffers?\" count)
     (delete-buffers)))"
  `(let ((answer (prompt-minibuffer
                  :input-prompt (format nil ,@prompt)
                  :suggestion-function (yes-no-suggestion-filter)
                  :hide-suggestion-count-p t)))
     (if (confirmed-p answer)
         ,yes-form
         ,no-form)))

;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
;;;; SPDX-License-Identifier: BSD-3-Clause

(in-package :nyxt)

(export-always '*yes-no-choices*)
(defparameter *yes-no-choices* '(:yes "yes" :no "no")
  "The suggestions when asking the user for a yes/no choice.
See `if-confirm'.
The first suggestion poses as a default.")

(defun yes-no-suggestion-filter ()
  (lambda (minibuffer)
    (fuzzy-match (input-buffer minibuffer) (sera:plist-values *yes-no-choices*))))

(defun confirmed-p (answer)
  (string-equal answer (getf *yes-no-choices* :yes)))

(export-always 'if-confirm)
(defmacro if-confirm (prompt yes-form &optional no-form)
  "Ask the user for confirmation before executing either YES-FORM or NO-FORM.
YES-FORM is executed on  \"yes\" answer, NO-FORM -- on \"no\".
PROMPT is a list fed to `format nil'.

Example usage defaulting to \"no\":

\(let ((*yes-no-choices* '(:no \"no\" :yes \"yes\")))
  (if-confirm (\"Are you sure to kill ~a buffers?\" count)
     (delete-buffers)))"
  `(let ((answer (prompt-minibuffer
                  :input-prompt (format nil ,@prompt)
                  :suggestion-function (yes-no-suggestion-filter)
                  :hide-suggestion-count-p t)))
     (if (confirmed-p answer)
         ,yes-form
         ,no-form)))

Fix typo in `if-confirm' docstring.

Fix typo in `if-confirm' docstring.


(defpackage lispkit
  (:use :gtk :gdk :gdk-pixbuf :gobject
        :drakma :cl-webkit
        :glib :gio :pango :cairo :common-lisp)
  (:export #:main))

(in-package :lispkit)

(defun main (&rest args)
  (declare (ignore args))
  (within-main-loop
    (let ((window (gtk-window-new :toplevel))
          (view (webkit.foreign:webkit-web-view-new)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (leave-gtk-main)))
      (gtk-container-add window view)
      (webkit.foreign:webkit-web-view-load-uri view "http://www.example.com")
      (gtk-widget-show-all window))))

(defpackage lispkit
  (:use :gtk :gdk :gdk-pixbuf :gobject
        :drakma :cl-webkit
        :glib :gio :pango :cairo :common-lisp)
  (:export #:main))

(in-package :lispkit)

(defun main (&rest args)
  (declare (ignore args))
  (within-main-loop
    (let ((window (gtk-window-new :toplevel))
          (view (webkit.foreign:webkit-web-view-new)))
      (g-signal-connect window "destroy"
                        (lambda (widget)
                          (declare (ignore widget))
                          (gtk-widget-destroy view)
                          (leave-gtk-main)))
      (gtk-container-add window view)
      (webkit.foreign:webkit-web-view-load-uri view "http://www.example.com")
      (gtk-widget-show-all window))))

Destroy the webview on frame exit

Destroy the webview on frame exit


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

(defun import-special-operators (environment)
  (loop for symbol being each external-symbol in '#:common-lisp
	when (special-operator-p symbol)
	  do (setf (sicl-env:special-operator symbol environment) t)))

;;; Enter every Common Lisp class into the environment.
(defun import-classes (environment)
  (loop for symbol being each external-symbol in '#:common-lisp
	for class = (find-class symbol nil)
	unless (null class)
	  do (setf (sicl-env:find-class symbol environment)
		   class)))

(defun import-variables (environment)
  (let ((variables '(*standard-input* *standard-output* *error-output*
		     *terminal-io* *trace-output* *query-io*
		     *print-base* *read-base* *package*)))
    (loop for symbol in variables
	  do (setf (sicl-env:special-variable symbol environment t)
		   (cl:symbol-value symbol)))))

(defun import-from-host-common-lisp (environment)
  (import-special-operators environment)
  (import-classes environment)
  (import-variables environment))

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

;;; Enter every Common Lisp class into the environment.
(defun import-classes (environment)
  (loop for symbol being each external-symbol in '#:common-lisp
	for class = (find-class symbol nil)
	unless (null class)
	  do (setf (sicl-env:find-class symbol environment)
		   class)))

(defun import-variables (environment)
  (let ((variables '(*standard-input* *standard-output* *error-output*
		     *terminal-io* *trace-output* *query-io*
		     *print-base* *read-base* *package*)))
    (loop for symbol in variables
	  do (setf (sicl-env:special-variable symbol environment t)
		   (cl:symbol-value symbol)))))

(defun import-from-host-common-lisp (environment)
  (import-classes environment)
  (import-variables environment))

Remove function IMPORT-SPECIAL-OPERATORS. No longer needed.


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

(in-package :glkit.asdf)

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

  :depends-on (:sdl2kit-examples :glkit)
  :pathname "examples"
  :serial t

  :components
  ((:file "vaos")
   (:file "vao-shader")))

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

(in-package :glkit.asdf)

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

  :depends-on (:sdl2kit-examples :glkit)
  :pathname "examples"
  :serial t

  :components
  ((:file "vaos")
   (:file "vao-shader")
   (:file "vao-shader-150")))

Add vao-shader-150 to the asd

Add vao-shader-150 to the asd


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


;;;; The MIT License (MIT)

;;;; Copyright (c) 2015 Huang Xuxing

;;;; 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.

(in-package :asdf-user)

(defsystem :cl-cat
  :version "0.0.0"
  :licence "MIT"
  :description ""
  :long-description ""
  :components
  ((:static-file "LICENSE")
   (:static-file "README.md")
   (:file "packages")
   (:file "category" :depends-on ("packages"))
   (:file "object" :depends-on ("packages" "category"))
   (:file "predicate" :depends-on ("packages" "category"))))

;;;; The MIT License (MIT)

;;;; Copyright (c) 2015 Huang Xuxing

;;;; 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.

(in-package :asdf-user)

(defsystem :cl-cat
  :version "0.0.0"
  :licence "MIT"
  :description "A category abstraction of CLOS."
  :components
  ((:static-file "LICENSE")
   (:static-file "README.md")
   (:file "packages")
   (:file "category" :depends-on ("packages"))
   (:file "object" :depends-on ("packages" "category"))
   (:file "predicate" :depends-on ("packages" "category"))))

Add short description in ASDF file

Add short description in ASDF file


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

Define save info for new AST class.

Define save info for new AST class.


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

(asdf:defsystem :cleavir-generate-ast-test
  :depends-on (:cleavir-generate-ast
	       :cleavir-ast-transformations
	       :cleavir-ast-interpreter)
  :serial t
  :components
  ((:file "packages")
   (:file "environment")
   (:file "minimal-compilation")
   (:file "generate-ast")))

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

(defsystem :cleavir-generate-ast-test
  :depends-on (:cleavir-generate-ast
	       :cleavir-ast-transformations
	       :cleavir-ast-interpreter)
  :serial t
  :components
  ((:file "packages")
   (:file "environment")
   (:file "minimal-compilation")
   (:file "generate-ast")))

Use package ASDF-USER for system definition.


(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 (instruction-may-be-removed-p instruction)
	 (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)

(defmethod instruction-may-be-removed-p
    ((instruction cleavir-ir:return-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 (instruction-may-be-removed-p instruction)
	 (push instruction useless-instructions)))
     initial-instruction)
    (mapc #'cleavir-ir:delete-instruction useless-instructions)))

Add method specialized to RETURN-INSTRUCTION.


;;;;; tré – Copyright (c) 2010,2012 Sven Michael Klose <pixel@copei.de>

(defun %hcache-remove (plc vals)
  (& plc vals
  	 (| (not .vals)
	 	(%hcache-remove plc .vals))
	 (| (hremove plc vals.)
		t)))

(defun hcache-remove (plc &rest vals)
  (%hcache-remove plc vals))

(defun %hcache (plc vals)
  (& plc vals
     (| (& (not .vals)
		   (href plc vals.))
	  	(%hcache (href plc vals.) .vals))))

(defun hcache (plc &rest vals)
  (%hcache plc vals))

(defun %=-hcache (x plc vals)
  (? .vals
     (%=-hcache x (| (href plc vals.)
	                 (= (href plc vals.) (make-hash-table)))
			    .vals)
     (= (href plc vals.) x)))

(defun (= hcache) (x plc &rest vals)
  (%=-hcache x plc vals))

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

(defun hcache-remove (plc &rest vals)
  (& plc vals
  	 (| (not .vals)
	 	(apply #'hcache-remove plc .vals))
	 (| (hremove plc vals.)
		t)))

(defun hcache (plc &rest vals)
  (& plc vals
     (| (& (not .vals)
		   (href plc vals.))
	  	(apply #'hcache (href plc vals.) .vals))))

(defun %=-hcache (x plc vals)
  (? .vals
     (%=-hcache x (| (href plc vals.)
	                 (= (href plc vals.) (make-hash-table)))
			    .vals)
     (= (href plc vals.) x)))

(defun (= hcache) (x plc &rest vals)
  (%=-hcache x plc vals))

Return NIL if place is NIL.

Return NIL if place is NIL.


(asdf:defsystem #:ttnr
  :depends-on (#:alexandria #:trees #:bmgraph #:bmgraph-bestpath #:minimal-graph)
  :components ((:file "ttnr")
	       (:file "utils")
	       (:file "series-parallel-optimizations")))

(asdf:defsystem #:ttnr
  :depends-on (#:alexandria #:bmgraph #:bmgraph-bestpath #:minimal-graph)
  :components ((:file "ttnr")
	       (:file "utils")
	       (:file "series-parallel-optimizations")))

Remove stale Trees system dependency

Remove stale Trees system dependency


;;;;; TRE environment
;;;;; Copyright (c) 2009 Sven Klose <pixel@copei.de>

(defun unique-0 (head tail)
  (when head
	(if (= head tail.)
	  (unique-0 head .tail)
	  (cons head
			(unique-0 tail. .tail)))))

(defun unique (x &key (test #'<=))
  (let sorted (sort x :test test)
    (unique-0 sorted. .sorted)))

;;;;; TRE environment
;;;;; Copyright (c) 2010 Sven Klose <pixel@copei.de>

(defun unique (x &key (test #'eql))
  (when x
	(if (member x. .x :test test)
	    (unique .x :test test)
		(cons x.
	    	  (unique .x :test test)))))

Use a more general algorithm.

UNIQUE: Use a more general algorithm.


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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DEFGENERIC.

;;; FIXME: Add options and methods
(defmacro defgeneric (&environment env name lambda-list)
  (let* ((arg-type (cleavir-code-utilities:lambda-list-type-specifier lambda-list))
	 (function-type `(function ,arg-type t)))
  `(progn (eval-when (:compile-toplevel)
	    (setf (sicl-global-environment:function-type ',name ,env)
		  ',function-type))
	  (eval-when (:load-toplevel :execute)
	    (ensure-generic-function
	     ',name
	     :lambda-list ',lambda-list
	     :environment sicl-global-environment:*global-environment*)))))

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DEFGENERIC.

;;; FIXME: Add options and methods
(defmacro defgeneric (&environment env name lambda-list)
  (let* ((arg-type (cleavir-code-utilities:lambda-list-type-specifier lambda-list))
	 (function-type `(function ,arg-type t)))
  `(progn (eval-when (:compile-toplevel)
	    (setf (sicl-global-environment:function-type ',name ,env)
		  ',function-type))
	  (eval-when (:load-toplevel :execute)
	    (ensure-generic-function
	     ',name
	     :lambda-list ',lambda-list
	     :environment
	     (load-time-value
	      (sicl-global-environment:global-environment)))))))

Use function for accessing global environment.


(asdf:defsystem :ichr
  :name "iCHR"
  :description "NES character bitmap converter"
  :author "Andy Hefner <ahefner@gmail.com>"
  :license "MIT-style license"
  :depends-on (:asm6502 :skippy)
  :serial t
  :components ((:file "ichr")))

(asdf:defsystem :ichr
  :name "iCHR"
  :description "NES character bitmap converter"
  :author "Andy Hefner <ahefner@gmail.com>"
  :license "MIT-style license"
  :version "1.0.0"
  :depends-on (:asm6502 :skippy)
  :serial t
  :components ((:file "ichr")))

Add version to ASD file

Add version to ASD file


;;
;; Copyright (c) 2010, Peter Seibel. All rights reserved.
;;

(defsystem gigamonkey-distcompiler
  :components
  ((:file "packages")
   (:file "tarhash" :depends-on ("packages"))
   (:file "distcompiler" :depends-on ("packages" "tarhash")))
  :depends-on (:ironclad
               :com.gigamonkeys.pathnames
               :com.gigamonkeys.utilities
               :com.gigamonkeys.macro-utilities))

;;
;; Copyright (c) 2010, Peter Seibel. All rights reserved.
;;

(defsystem gigamonkey-distcompiler
  :components
  :description "Tool for generating Quicklisp dists."
  ((:file "packages")
   (:file "tarhash" :depends-on ("packages"))
   (:file "distcompiler" :depends-on ("packages" "tarhash")))
  :depends-on (:ironclad
               :com.gigamonkeys.pathnames
               :com.gigamonkeys.utilities
               :com.gigamonkeys.macro-utilities))

Add description to .asd file.

Add description to .asd file.


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

(setf (documentation 'left 'function)
      (format nil "Given a binary tree, obtain the left child of that tree.~@
                   If an object other than a binary tree is given,~@
                   then an error of type INVALID-BINARY-TREE is signaled."))

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

(setf (documentation 'left 'function)
      (format nil "Given a binary tree, return the left child of that tree.~@
                   If an object other than a binary tree is given,~@
                   then an error of type INVALID-BINARY-TREE is signaled."))

(setf (documentation 'right 'function)
      (format nil "Given a binary tree, return the right child of that tree.~@
                   If an object other than a binary tree is given,~@
                   then an error of type INVALID-BINARY-TREE is signaled."))

Add docstring for function RIGHT.

Add docstring for function RIGHT.


;;;; System definition for TRIVIAL-DOCUMENTATION.

(defsystem trivial-documentation
  :description
  "Extract documentation and definitions for symbols and packages."
  :author "Max Rottenkolber <max@mr.gy>"
  :license "GNU AGPL"
  :components ((:file "extract"))
  :depends-on ("closer-mop"))

;;;; System definition for TRIVIAL-DOCUMENTATION.

(defsystem trivial-documentation
  :description
  "Extract documentation and definitions for symbols and packages."
  :author "Max Rottenkolber <max@mr.gy>"
  :license "GNU AGPL"
  :components ((:file "extract"))
  :depends-on ("closer-mop" #+sbcl"sb-introspect"))

Add sb-introspect dependency on SBCL.

Add sb-introspect dependency on SBCL.


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

(in-package :swap-bytes)

#+x86
(defun swap-bytes-16 (integer)
  (declare (type (unsigned-byte 16) integer))
  (swap-bytes-16 integer))

(defun swap-bytes-32 (integer)
  (declare (type (unsigned-byte 32) integer))
  (swap-bytes-32 integer))

#+x86-64
(defun swap-bytes-64 (integer)
  (declare (type (unsigned-byte 64) integer))
  (swap-bytes-64 integer))

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

(in-package :swap-bytes)

#+x86
(defun swap-bytes-16 (integer)
  (declare (type (unsigned-byte 16) integer))
  (swap-bytes-16 integer))

#+(or x86 x86-64)
(defun swap-bytes-32 (integer)
  (declare (type (unsigned-byte 32) integer))
  (swap-bytes-32 integer))

#+x86-64
(defun swap-bytes-64 (integer)
  (declare (type (unsigned-byte 64) integer))
  (swap-bytes-64 integer))

Add reader conditional for clarity

Add reader conditional for clarity


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

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

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

Remove definition of class STANDARD-CLASS in compilation environment.


;;; -*- Lisp -*- mode
(defpackage #:split-sequence-system (:use #:cl #:asdf))
(in-package :split-sequence-system)

(defsystem :split-sequence
    :version "20011114.1"
  :components ((:file "split-sequence"))
  :in-order-to ((asdf:test-op (asdf:load-op :split-sequence-tests)))
  :perform (asdf:test-op :after (op c)
             (funcall (intern (symbol-name '#:run!) '#:5am) :split-sequence)))

(defsystem :split-sequence-tests
  :depends-on (:split-sequence :fiveam)
  :components ((:file "tests")))

;;; -*- Lisp -*-

(defsystem :split-sequence
    :version "20011114.1"
  :components ((:file "split-sequence"))
  :in-order-to ((asdf:test-op (asdf:load-op :split-sequence-tests)))
  :perform (asdf:test-op :after (op c)
             (funcall (intern (symbol-name '#:run!) '#:5am) :split-sequence)))

(defsystem :split-sequence-tests
  :depends-on (:split-sequence :fiveam)
  :components ((:file "tests")))

Remove useless DEFPACKAGE from the .asd file


(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/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/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 METHOD-COMBINATION.


(in-package :cl-user)
(defpackage integral-test.init.postgres
  (:use :cl
        :integral)
  (:export :connect-to-testdb))
(in-package :integral-test.init.postgres)

(defun connect-to-testdb ()
  (disconnect-toplevel)
  (connect-toplevel :postgres
                    :database-name "integral_test"
                    :username "nitro_idiot"))

(in-package :cl-user)
(defpackage integral-test.init.postgres
  (:use :cl
        :integral)
  (:export :connect-to-testdb))
(in-package :integral-test.init.postgres)

(defun connect-to-testdb ()
  (disconnect-toplevel)
  (connect-toplevel :postgres
                    :database-name "integral_test"
                    :username "nobody"))

Fix the user name of PostgreSQL.

Fix the user name of PostgreSQL.


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

(defmacro setf (&environment env place new-value-form &rest more-pairs)
  (cond ((null more-pairs)
	 (multiple-value-bind (variables
			       values
			       store-variables
			       writer-form
			       reader-form)
	     (sicl-env:get-setf-expansion place env)
	   (declare (ignire reader-form))
	   `(let* ,(mapcar #'list variables values)
	      ;; Optimize a bit when there is only one store variable.
	      ,(if (= 1 (length store-variables))
		   `(let ((,(first store-variables) ,new-value-form))
		      ,writer-form)
		   `(multiple-value-bind ,store-variables
			,new-value-form
		      ,writer-form)))))
	((not (null (cdr more-pairs)))
	 `(progn (setf ,place ,new-value-form)
		 (setf ,@more-pairs)))
	(t
	 (error "Odd number of arguments to SETF."))))

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

(defmacro setf (&whole form &environment env place new-value-form &rest more-pairs)
  (cond ((null more-pairs)
	 (multiple-value-bind (variables
			       values
			       store-variables
			       writer-form
			       reader-form)
	     (sicl-env:get-setf-expansion place env)
	   (declare (ignire reader-form))
	   `(let* ,(mapcar #'list variables values)
	      ;; Optimize a bit when there is only one store variable.
	      ,(if (= 1 (length store-variables))
		   `(let ((,(first store-variables) ,new-value-form))
		      ,writer-form)
		   `(multiple-value-bind ,store-variables
			,new-value-form
		      ,writer-form)))))
	((not (null (cdr more-pairs)))
	 `(progn (setf ,place ,new-value-form)
		 (setf ,@more-pairs)))
	(t
	 (error 'odd-number-of-arguments-to-setf :form form))))

Use new condition to report syntax error in SETF.


(in-package :sicl.tags)

;;; Number of bytes in a machine word.
(cl:defparameter +machine-word-length+ 64)

;;; The basic type that raw memory contains.
(cl:deftype machine-word ()
  `(cl:unsigned-byte ,+machine-word-length+))

;;; Number of bits used for first-order tag
(cl:defparameter +number-of-low-tag-bits+ 3)

;;; A mask of 1s corresponding to the low tag bits
(cl:defparameter +low-tag-mask+
  (cl:1- (cl:round (cl:expt 2 +number-of-low-tag-bits+))))

(cl:defun tag-bits (word)
  (cl:check-type object machine-word)
  (cl:logand word +low-tag-mask+))

(cl:defun raw-pointer (word)
  (cl:check-type object machine-word)
  (cl:logand word (cl:not +low-tag-mask+)))

(cl:in-package #:sicl.tags)

;;; Number of bytes in a machine word.
(cl:defparameter +machine-word-length+ 64)

;;; The basic type that raw memory contains.
(cl:deftype machine-word ()
  `(cl:unsigned-byte ,+machine-word-length+))

;;; Number of bits used for first-order tag
(cl:defparameter +number-of-low-tag-bits+ 3)

;;; A mask of 1s corresponding to the low tag bits
(cl:defparameter +low-tag-mask+
  (cl:1- (cl:round (cl:expt 2 +number-of-low-tag-bits+))))

(cl:defun tag-bits (word)
  (cl:check-type object machine-word)
  (cl:logand word +low-tag-mask+))

(cl:defun raw-pointer (word)
  (cl:check-type object machine-word)
  (cl:logand word (cl:not +low-tag-mask+)))

Use explicit package marker for IN-PACKAGE.


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

(defparameter *syntax-trees* '())

(defun read (&optional
	       (input-stream *standard-input*)
	       (eof-error-p t)
	       (eof-value nil)
	       (recursive-p nil))
  (let ((*preserve-whitespace* recursive-p)
	(*syntax-trees* (cons (list nil) *syntax-trees*)))
    (let ((result (read-common input-stream eof-error-p eof-value)))
      (push result (cadr *syntax-trees*))
      result)))

(defun read-with-source-tracking
    (&optional (a nil a-p) (b nil b-p) (c nil c-p) (d nil d-p))
  (let* ((*syntax-trees* (list nil))
	 (result (if a-p
		     (if b-p
			 (if c-p
			     (if d-p
				 (read a b c d)
				 (read a b c))
			     (read a b))
			 (read a))
		     (read))))
    (values result (car *syntax-trees*))))

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

(defparameter *syntax-trees* '())

(defun read (&optional
	       (input-stream *standard-input*)
	       (eof-error-p t)
	       (eof-value nil)
	       (recursive-p nil))
  (let ((*preserve-whitespace* recursive-p)
	(*syntax-trees* (cons (list nil) *syntax-trees*)))
    (let ((result (read-common input-stream eof-error-p eof-value)))
      (push result (cadr *syntax-trees*))
      result)))

(defun read-with-source-tracking
    (&optional
       (stream *standard-input* stream-p)
       (b nil b-p) (c nil c-p) (d nil d-p))
  (let* ((*syntax-trees* (list nil))
	 (result (if stream-p
		     (if b-p
			 (if c-p
			     (if d-p
				 (read stream b c d)
				 (read stream b c))
			     (read stream b))
			 (read stream))
		     (read))))
    (values result (car *syntax-trees*))))

Rename stream argument and give it a reasonable default value.


(in-package :brreg)

(push (cons "application" "json") drakma:*text-content-types*)

(defun get-jsonhash (orgnummer)
  (when (and (every #'digit-char-p orgnummer)
             (= (length orgnummer) 9))
    (multiple-value-bind (response status)
        (drakma:http-request
         (format nil "http://data.brreg.no/enhetsregisteret/enhet/~A.json"
                 orgnummer))
      (when (eql status 200)
        (yason:parse response)))))

(defun get-orgfeature (feature orgnummer)
  (ignore-errors
   (let ((hash (get-jsonhash orgnummer)))
     (if hash
         (gethash feature hash)
         (make-hash-table)))))

(defun get-org-name (orgnummer)
  (let ((navn (get-orgfeature "navn" orgnummer)))
    (when (stringp navn)
      navn)))

(defun get-org-address (orgnummer)
  (ignore-errors
   (gethash "adresse" (get-orgfeature "forretningsadresse" orgnummer))))

(defun get-org-postnummer (orgnummer)
  (ignore-errors
   (gethash "postnummer" (get-orgfeature "forretningsadresse" orgnummer))))

(defun get-org-poststed (orgnummer)
  (ignore-errors
   (gethash "poststed" (get-orgfeature "forretningsadresse" orgnummer))))

(in-package :brreg)

(push (cons "application" "json") drakma:*text-content-types*)

(defun get-jsonhash (orgnummer)
  (when (and (every #'digit-char-p orgnummer)
             (= (length orgnummer) 9))
    (multiple-value-bind (response status)
        (drakma:http-request
         (format nil "http://data.brreg.no/enhetsregisteret/enhet/~A.json"
                 orgnummer))
      (when (eql status 200)
        (yason:parse response)))))

(defun get-orgfeature (feature orgnummer)
  (ignore-errors
   (gethash feature (get-jsonhash orgnummer))))

(defun get-org-name (orgnummer)
  (get-orgfeature "navn" orgnummer))

(defun get-org-address (orgnummer)
  (ignore-errors
   (gethash "adresse" (get-orgfeature "forretningsadresse" orgnummer))))

(defun get-org-postnummer (orgnummer)
  (ignore-errors
   (gethash "postnummer" (get-orgfeature "forretningsadresse" orgnummer))))

(defun get-org-poststed (orgnummer)
  (ignore-errors
   (gethash "poststed" (get-orgfeature "forretningsadresse" orgnummer))))

Return NIL for all errors.

Return NIL for all errors.


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

(defsystem :cleavir-ssa-form
  :depends-on (:cleavir-utilities
	       :cleavir-dominance)
  :components
  ((:file "packages")
   (:file "ssa-form" :depends-on ("packages"))))

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

(defsystem :cleavir-ssa-form
  :depends-on (:cleavir-utilities
	       :cleavir-dominance)
  :serial t
  :components
  ((:file "packages")
   (:file "ssa-form")))

Simplify system by using option :SERIAL T.


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

(defparameter *syntax-trees* '())

(defun read (&optional
	       (input-stream *standard-input*)
	       (eof-error-p t)
	       (eof-value nil)
	       (recursive-p nil))
  (let ((*preserve-whitespace* recursive-p)
	(*syntax-trees* (cons (list nil) *syntax-trees*)))
    (let ((result (read-common input-stream eof-error-p eof-value)))
      (push result (cadr *syntax-trees*))
      result)))

(defun read-with-source-tracking
    (&optional
       (stream *standard-input* stream-p)
       (b nil b-p) (c nil c-p) (d nil d-p))
  (let* ((*syntax-trees* (list nil))
	 (result (if stream-p
		     (if b-p
			 (if c-p
			     (if d-p
				 (read stream b c d)
				 (read stream b c))
			     (read stream b))
			 (read stream))
		     (read))))
    (values result (car *syntax-trees*))))

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

(defparameter *syntax-trees* '())

(defun sicl-reader:read
    (&optional
       (input-stream *standard-input*)
       (eof-error-p t)
       (eof-value nil)
       (recursive-p nil))
  (let ((sicl-reader::*preserve-whitespace* recursive-p)
	(*syntax-trees* (cons (list nil) *syntax-trees*)))
    (let ((result (sicl-reader::read-common input-stream eof-error-p eof-value)))
      (push result (cadr *syntax-trees*))
      result)))

(defun read-with-source-tracking
    (&optional
       (stream *standard-input* stream-p)
       (b nil b-p) (c nil c-p) (d nil d-p))
  (let* ((*syntax-trees* (list nil))
	 (result (if stream-p
		     (if b-p
			 (if c-p
			     (if d-p
				 (read stream b c d)
				 (read stream b c))
			     (read stream b))
			 (read stream))
		     (read))))
    (values result (car *syntax-trees*))))

Use specific package and adjust references accordingly.


;; Common Lisp Script
;; Manoel Vilela

(defun reverse-digits (n)
  (labels ((next (n v)
             (if (zerop n)
                 v
                 (multiple-value-bind (q r)
                     (truncate n 10)
                   (next q (+ (* v 10) r))))))
    (next n 0)))

(defun palindromep (n)
  (= n (reverse-digits n)))

(defun solution()
  (loop for x from 100 to 999
        maximize (loop for y from 100 to 999
                       for p = (* x y)
                       when (palindromep p) maximize p)))

(format t "~a ~%"(solution))

;; Common Lisp Script
;; Manoel Vilela

(defun reverse-digits (n)
  (labels ((next (n v)
             (if (zerop n)
                 v
                 (multiple-value-bind (q r)
                     (truncate n 10)
                   (next q (+ (* v 10) r))))))
    (next n 0)))

(defun palindromep (n)
  (= n (reverse-digits n)))

(defun solution()
  (loop for x from 100 to 999
        for m = (loop for y from 100 to 999
                      for p = (* x y)
                      when (palindromep p) maximize p)
        when (numberp m) maximize m))

(format t "~a ~%"(solution))

Fix a problem with CLISP compilation

Problem004: Fix a problem with CLISP compilation

Sometimes the nested loop may return nil and, at least CLISP, maximize
keyword expansion need be a REAL number.

This doesn't occurs in SBCL. By the way, SBCL execution is much much faster.

CLISP: 10.153 s
SBCL: 0.230 s

Maybe I need change the compiler on ./stats.py later


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

;;; Add every global environment function into the environment.
(defun import-from-sicl-global-environment (environment)
  (loop for symbol being each external-symbol in '#:sicl-global-environment
	when (fboundp symbol)
	  do (setf (sicl-env:fdefinition symbol environment)
		   (fdefinition symbol))
	when (fboundp `(setf ,symbol))
	  do (setf (sicl-env:fdefinition `(setf ,symbol) environment)
		   (fdefinition `(setf ,symbol)))))

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

;;; Add every global environment function into the environment.
(defun import-from-sicl-global-environment (environment)
  (loop for symbol being each external-symbol in '#:sicl-global-environment
	when (fboundp symbol)
	  do (setf (sicl-env:fdefinition symbol environment)
		   (fdefinition symbol))
	when (fboundp `(setf ,symbol))
	  do (setf (sicl-env:fdefinition `(setf ,symbol) environment)
		   (fdefinition `(setf ,symbol))))
  (setf (sicl-env:special-variable 'sicl-env:*global-environment* environment t)
	environment))

Define variable *GLOBAL-ENVIRONMENT* in the exitrinsic environment.


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

Define method on REPLACE specialized to 2-NODE.


(in-package :cl-user)

(defpackage #:local-function-asd
  (:use :cl :asdf) )

(in-package #:local-function-asd)

(defsystem local-function
  :name "local-function"
  :version "0.2.0"
  :maintainer "SUZUKI Shingo"
  :author "SUZUKI Shingo"
  :licence "MIT"
  :description "local-function: a variant of named-let with no-return feature"
  :serial nil
  :components
    ((:file "local-function")) )

(defmethod perform ((op test-op)
                    (compo (eql (find-system :local-function))) )
  (declare (ignore op comp))
  (operate 'load-op :local-function-test)
  (operate 'test-op :local-function-test :force t) )

(in-package :cl-user)

(defpackage #:local-function-asd
  (:use :cl :asdf) )

(in-package #:local-function-asd)

(defsystem local-function
  :name "local-function"
  :version "0.2.0"
  :maintainer "SUZUKI Shingo"
  :author "SUZUKI Shingo"
  :licence "MIT"
  :description "local-function: a variant of named-let with no-return feature"
  :serial nil
  :components
    ((:file "local-function")) )

(defmethod perform ((op test-op)
                    (component (eql (find-system :local-function))) )
  (declare (ignore op component))
  (operate 'load-op :local-function-test)
  (operate 'test-op :local-function-test :force t) )

Fix ambiguous parameter name and its typo


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

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

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

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

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

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

Load a file containing the definition of the class SPECIALIZER.


(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)
    (when (eql char #\Newline)
      (setf (column stream) 0)
      (incf (line 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)))

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

Increment column count in default case.

Increment column count in default case.


; tré – Copyright (C) 2006,2008,2012,2014–2015 Sven Michael Klose <pixel@hugbox.org>

(defmacro with-struct (typ strct &body body)
  (alet (assoc-value typ *struct-defs*)
    `(let* ((,typ ,strct)
            ,@(@ [let n (%struct-field-name _)
	               `(,n (,(%struct-accessor-name typ n) ,strct))]
                 !))
       ,@(@ [%struct-field-name _] !)
       ,@body)))

; tré – Copyright (C) 2006,2008,2012,2014–2015 Sven Michael Klose <pixel@hugbox.org>

(defmacro with-struct (typ strct &body body)
  (alet (assoc-value typ *struct-defs*)
    `(#'((,typ ,@(@ #'%struct-field-name !))
           ,@(@ [%struct-field-name _] !)
           ,@body)
       ,strct ,@(@ [`(,(%struct-accessor-name typ (%struct-field-name _)) ,strct)] !))))

Make only a single function for all slots.


(asdf:defsystem #:hexstream-project-template

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

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

  :description "I unsophistically copy/paste and rename/modify these files to start a new project, currently."

  :depends-on ()

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

Remove 2 extraneous spaces in ASD file.

Remove 2 extraneous spaces in ASD file.