;;;; -*- lisp -*-

(in-package :cl-user)

(defpackage :parenscript.system
  (:use :cl :asdf))

(in-package :parenscript.system)

(defsystem :parenscript
  :name "parenscript"
  :author "Manuel Odendahl <manuel@bl0rg.net>"
  :version "0"
  :maintainer "Edward Marco Baringer <mb@bese.it>"
  :licence "BSD"
  :description "js - javascript compiler"

  :perform (load-op :after (op araneida)
                    (pushnew :parenscript cl:*features*))
  :components ((:static-file "parenscript.asd")
               (:module :src
                :components ((:file "package")
                             (:file "utils" :depends-on ("package"))
                             (:file "defgenerics" :depends-on ("package"))
                             (:file "js" :depends-on ("package" "utils" "defgenerics"))
                             (:file "js-html" :depends-on ("package" "js" "utils"))
                             (:file "css" :depends-on ("package" "utils"))))))

(defsystem :parenscript.test
  :depends-on (:parenscript :fiveam :cl-ppcre)
  :components ((:module :t
                :components ((:file "test-package")
                             (:file "test" :depends-on ("test-package"))
                             (:file "ref2test" :depends-on ("test"))
                             (:file "reference-tests" :depends-on ("test"))))))

;;;; -*- lisp -*-

(in-package :cl-user)

(defpackage :parenscript.system
  (:use :cl :asdf))

(in-package :parenscript.system)

(defsystem :parenscript
  :name "parenscript"
  :author "Manuel Odendahl <manuel@bl0rg.net>"
  :version "0"
  :maintainer "Edward Marco Baringer <mb@bese.it>"
  :licence "BSD"
  :description "js - javascript compiler"
  :components ((:static-file "parenscript.asd")
               (:module :src
                :components ((:file "package")
                             (:file "utils" :depends-on ("package"))
                             (:file "defgenerics" :depends-on ("package"))
                             (:file "js" :depends-on ("package" "utils" "defgenerics"))
                             (:file "js-html" :depends-on ("package" "js" "utils"))
                             (:file "css" :depends-on ("package" "utils"))
                             (:file "compile-js" :depends-on ("package" "js"))))))

(defmethod asdf:perform :after ((op asdf:load-op) (system (eql (asdf:find-system :parenscript))))
  (pushnew :parenscript cl:*features*))

(defsystem :parenscript.test
  :depends-on (:parenscript :fiveam :cl-ppcre)
  :components ((:module :t
                :components ((:file "test-package")
                             (:file "test" :depends-on ("test-package"))
                             (:file "ref2test" :depends-on ("test"))
                             (:file "reference-tests" :depends-on ("test"))))))

Use an explicit asdf:perform :after method instead of :perform (load-op :after ...)


(cl:defpackage #:macro-level_tests
  (:use #:cl #:parachute)
  (:import-from #:macro-level #:macro-level))

(cl:in-package #:macro-level_tests)

(define-test "main"
  (is equal
      (let ((alist nil))
        (macro-level `(progn ,@(mapcar (lambda (var value)
                                         (let ((var (intern (format nil "*~A*" var) '#:macro-level_tests)))
                                           `(push '(,var . ,value) alist)))
                                       '(a b c)
                                       '(1 2 3))))
        (nreverse alist))
      '((*a* . 1) (*b* . 2) (*c* . 3))))

(cl:defpackage #:macro-level_tests
  (:use #:cl #:parachute)
  (:import-from #:macro-level #:macro-level))

(cl:in-package #:macro-level_tests)

(define-test "main"
  (is equal '((*a* . 1) (*b* . 2) (*c* . 3))
      (let ((alist nil))
        (macro-level `(progn ,@(mapcar (lambda (var value)
                                         (let ((var (intern (format nil "*~A*" var) '#:macro-level_tests)))
                                           `(push '(,var . ,value) alist)))
                                       '(a b c)
                                       '(1 2 3))))
        (nreverse alist))))

Use proper argument order for IS.

Tests: Use proper argument order for IS.


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

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

(defun define-ensure-generic-function (environment)
  (setf (sicl-genv:fdefinition 'ensure-generic-function environment)
	(lambda (function-name &rest arguments)
	  (if (sicl-genv:fboundp function-name environment)
	      (sicl-genv:fdefinition function-name environment)
	      (let ((new-arguments (copy-list arguments)))
		(loop while (remf new-arguments :environment))
		(setf (sicl-genv:fdefinition function-name environment)
		      (apply #'make-instance
			     (sicl-genv:find-class
			      'standard-generic-function
			      (phase1-environment environment))
			     new-arguments)))))))

(defun fill-environment (environment)
  (define-ensure-generic-function environment))

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

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

(defun define-ensure-generic-function (environment)
  (setf (sicl-genv:fdefinition 'ensure-generic-function environment)
	(lambda (function-name &rest arguments)
	  (if (sicl-genv:fboundp function-name environment)
	      (sicl-genv:fdefinition function-name environment)
	      (let ((new-arguments (copy-list arguments)))
		(loop while (remf new-arguments :environment))
		(setf (sicl-genv:fdefinition function-name environment)
		      (apply #'make-instance
			     (sicl-genv:find-class
			      'standard-generic-function
			      (phase1-environment environment))
			     new-arguments)))))))

(defun fill-environment (environment)
  (define-ensure-generic-function environment)
  (sicl-genv:fmakunbound 'sicl-clos:class-direct-superclasses environment)
  (ld "../../CLOS/class-direct-superclasses-defgeneric.lisp" environment))

Load a file containing the definition of the generic function CLASS-DIRECT-SUPERCLASSES.


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

(defmacro with-default-stream (nstr str &rest body)
"Set 'str' to *standard-output* if 'str' is T or create string-stream
if 'str' is NIL, evaluate 'body' and return the stream-string if 'str'
is NIL."
  (with-gensym g
    `(with (,g ,str
			,nstr nil)
	   (setq ,nstr (if
        		     (eq ,g t)		*standard-output*
        		     (eq ,g nil)	(make-string-stream)
				     ,g))
       ,@body
       (unless ,g
         (get-stream-string ,nstr)))))

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

(defmacro with-default-stream (nstr str &rest body)
"Set 'str' to *standard-output* if 'str' is T or create string-stream
if 'str' is NIL, evaluate 'body' and return the stream-string if 'str'
is NIL."
  (with-gensym (g body-result)
    `(with (,g ,str
			,nstr nil)
	   (setq ,nstr (if
        		     (eq ,g t)		*standard-output*
        		     (eq ,g nil)	(make-string-stream)
				     ,g))
       (let ,body-result (progn
						   ,@body)
         (if ,g
		   ,body-result
           (get-stream-string ,nstr))))))

Return body result if string is not a string-stream.


(fn warn-unused-functions ()
  (!= (defined-functions)
    (@ [hremove ! _]
       (+ (hashkeys (used-functions))
          (hashkeys (expander-macros (transpiler-macro-expander)))
          (hashkeys (expander-macros (codegen-expander)))
          *macros*))
    (@ [!= (symbol-name _)
         (| (tail? ! "_TREEXP")
            (head? ! "~")
            (warn "Unused function ~A." _))]
       (hashkeys !))))

(fn warn-unused-functions ()
  (!= (defined-functions)
    (@ [hremove ! _]
       (+ (hashkeys (used-functions))
          (hashkeys (expander-macros (transpiler-macro-expander)))
          (hashkeys (expander-macros (codegen-expander)))
          *macros*))
    (!? (mapcan [!= (symbol-name _)
                  (& (not (tail? ! "_TREEXP")
                          (head? ! "~"))
                     (list !))]
           (hashkeys !))
      (warn "Unused functions: ~A." (symbol-names-string !)))))

Print one list of names of unused functions.


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

(asdf:defsystem :clobber
  :components
  ((:file "packages")
   (:file "clobber" :depends-on ("packages"))
   (:file "demo" :depends-on ("clobber"))
   (:file "demo2" :depends-on ("clobber"))))

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

(defsystem :clobber
  :components
  ((:file "packages")
   (:file "clobber" :depends-on ("packages"))
   (:file "demo" :depends-on ("clobber"))
   (:file "demo2" :depends-on ("clobber"))))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


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

(defsystem acronyms
  :name "Acronym Expander"
  :version "1.0.0"
  :licence "MIT"
  :description "A program that expands an acronym based on grammatical rules."
  :serial t
  :components ((:file "acronyms")))

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

(defsystem 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 "acronyms")))

Add author and maintainer field.

Add author and maintainer field.


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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Mixin classes for instructions according to successor count.

;;; Mixin class for instructions with no successors.
(defclass no-successors-mixin () ())

;;; Mixin class for instructions with a single successor.
(defclass one-successor-mixin () ())

;;; Mixin class for instructions with tow successors.
(defclass two-successors-mixin () ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Other mixin classes.

;;; Mixin class for instructions that have side effects so that they
;;; should not be removed.
(defclass side-effect-mixin () ())

Define mixin class for instructions with side effects.


(in-package :hunchentoot)

(format t "Am I alive??")
(format t "Dispatch ~A~%" *dispatch-table*)

(hunchentoot:define-easy-handler (say-yo :uri "/yo") (name)
  (setf (hunchentoot:content-type*) "text/plain")
  (progn
  	(format nil "Hey~@[ ~A~]!~%" name)
  	(format nil "~A ~A" (lisp-implementation-type) (lisp-implementation-version))))

;(publish :path "/"
;	 :function #'(lambda (req ent)
;		       (with-http-response (req ent)
;			 (with-http-body (req ent)
;			   (html
;			    (:h1 "Hello World")
;			    (:princ "Congratulations, you are running Lisp on Heroku!!!")
;			    :p
;			    ((:img :src "lisp-glossy.jpg"))
;			    )))))
;
;(publish-directory
; :prefix "/"
; :destination "./public/"
; )

(in-package :hunchentoot)

(format t "Am I alive??")
(format t "Dispatch ~A~%" *dispatch-table*)

(hunchentoot:define-easy-handler (say-yo :uri "/yo") (name)
  (setf (hunchentoot:content-type*) "text/plain")
  (format nil "Hey~@[ ~A~]! ~A ~A" name (lisp-implementation-type) (lisp-implementation-version)))

;(publish :path "/"
;	 :function #'(lambda (req ent)
;		       (with-http-response (req ent)
;			 (with-http-body (req ent)
;			   (html
;			    (:h1 "Hello World")
;			    (:princ "Congratulations, you are running Lisp on Heroku!!!")
;			    :p
;			    ((:img :src "lisp-glossy.jpg"))
;			    )))))
;
;(publish-directory
; :prefix "/"
; :destination "./public/"
; )

Tweak greeting and impl info.

Tweak greeting and impl info.


;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-

;;;;     Copyright (C) 2014  Varoun. P

;;;;     This program is free software: you can redistribute it and/or modify
;;;;     it under the terms of the GNU Affero General Public License as
;;;;     published by the Free Software Foundation, either version 3 of the
;;;;     License, or (at your option) any later version.

;;;;     This program is distributed in the hope that it will be useful,
;;;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;     GNU Affero General Public License for more details.

;;;;     You should have received a copy of the GNU Affero General Public License
;;;;     along with this program.  If not, see <http://www.gnu.org/licenses/>.

(in-package "STREAMLETS-IMPL")

;;;; The foundation class for all tuples.

(defclass tuple ()
  ((metrics
    :initarg :tuple-metrics
    :initform nil
    :accessor tuple-metrics
    :documentation "A list of metrics relevant to tuple processing.")))

;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-

;;;;     Copyright (C) 2014  Varoun. P

;;;;     This program is free software: you can redistribute it and/or modify
;;;;     it under the terms of the GNU Affero General Public License as
;;;;     published by the Free Software Foundation, either version 3 of the
;;;;     License, or (at your option) any later version.

;;;;     This program is distributed in the hope that it will be useful,
;;;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;     GNU Affero General Public License for more details.

;;;;     You should have received a copy of the GNU Affero General Public License
;;;;     along with this program.  If not, see <http://www.gnu.org/licenses/>.

(in-package "STREAMLETS-IMPL")

;;;; Streamlets Tuples

(defclass tuple ()
  ((metrics
    :initarg :tuple-metrics
    :initform nil
    :accessor tuple-metrics
    :documentation "A list of metrics relevant to tuple processing."))
  (:documentation "The foundation for all tuples."))

Add documentation to the tuple class.

Add documentation to the tuple class.


;   Copyright 2017 James Fleming <james@electronic-quill.net>
;
;   Licensed under the GNU General Public License
;   - for details, see LICENSE.txt in the top-level directory

;;;; Logging infrastructure
;;; We only need something extremely simple

(in-package #:neo4cl)

(defvar *loglevels*
  '(:crit 4
    :critical 4
    :error 3
    :warn 2
    :warning 2
    :info 1
    :debug 0))

;; Set the threshold logging level
(defparameter *loglevel* :debug)

(defparameter *log-stream*
  (make-synonym-stream 'cl:*standard-output*))

(defun make-timestamp ()
  (multiple-value-bind (sec minute hour date month year)
    (get-decoded-time)
    (format nil "[~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d]"
    year month date hour minute sec)))

(defun log-message (severity message)
  (declare (type keyword severity))
  (when (>= (getf *loglevels* severity)
            (getf *loglevels* *loglevel*))
    (format *log-stream* "~%~A ~A ~A"
            (make-timestamp)
            severity
            message)))

;   Copyright 2017 James Fleming <james@electronic-quill.net>
;
;   Licensed under the GNU General Public License
;   - for details, see LICENSE.txt in the top-level directory

;;;; Logging infrastructure
;;; We only need something extremely simple

(in-package #:neo4cl)

(defvar *loglevels*
  '(:crit 4
    :critical 4
    :error 3
    :warn 2
    :warning 2
    :info 1
    :debug 0))

;; Set the threshold logging level
(defparameter *loglevel* :warn)

(defparameter *log-stream*
  (make-synonym-stream 'cl:*standard-output*))

(defun make-timestamp ()
  (multiple-value-bind (sec minute hour date month year)
    (get-decoded-time)
    (format nil "[~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d]"
    year month date hour minute sec)))

(defun log-message (severity message)
  (declare (type keyword severity))
  (when (>= (getf *loglevels* severity)
            (getf *loglevels* *loglevel*))
    (format *log-stream* "~%~A ~A ~A"
            (make-timestamp)
            severity
            message)))

Change default loglevel from :debug to :warn


(bodge-util:define-package :cl-bodge.ui
  (:nicknames :ge.ui)
  (:use :cl :cl-bodge.engine :bodge-util :cl-bodge.graphics
        :cl-bodge.canvas :cl-bodge.resources :claw)
  (:reexport-from :bodge-ui
                  #:defwindow
                  #:on-window-close

                  #:horizontal-layout
                  #:vertical-layout

                  #:label
                  #:radio-group
                  #:radio
                  #:check-box
                  #:button

                  #:custom-widget
                  #:custom-widget-hovered-p
                  #:custom-widget-pressed-p
                  #:render-custom-widget)
  (:export #:make-ui
           #:compose-ui
           #:with-ui-access
           #:add-window
           #:remove-window
           #:remove-all-windows

           #:update-ui-size
           #:update-ui-pixel-ratio

           #:make-host-input-source
           #:attach-host-input-source
           #:detach-host-input-source))

(bodge-util:define-package :cl-bodge.ui
  (:nicknames :ge.ui)
  (:use :cl :cl-bodge.engine :bodge-util :cl-bodge.graphics
        :cl-bodge.canvas :cl-bodge.resources :claw)
  (:reexport-from :bodge-ui
                  #:defpanel
                  #:on-window-close

                  #:horizontal-layout
                  #:vertical-layout

                  #:label
                  #:radio-group
                  #:radio
                  #:check-box
                  #:button

                  #:custom-widget
                  #:custom-widget-hovered-p
                  #:custom-widget-pressed-p
                  #:render-custom-widget)
  (:export #:make-ui
           #:compose-ui
           #:with-ui-access
           #:add-window
           #:remove-window
           #:remove-all-windows

           #:update-ui-size
           #:update-ui-pixel-ratio

           #:make-host-input-source
           #:attach-host-input-source
           #:detach-host-input-source))

Update for latest bodge-ui changes

Update for latest bodge-ui changes


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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class OPTIMIZE-AST.

(defclass optimize-ast (ast)
  ((%child-ast :initarg :child-ast :reader child-ast)
   (%value-ast :initarg :value-ast :reader value-ast)))

(cleavir-io:define-save-info optimize-ast
  (:child-ast child-ast)
  (:value-ast value-ast))

(defmethod children ((ast optimize-ast))
  (list (child-ast ast)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class SPEED-AST.

(defclass speed-ast (optimize-ast)
  ())

(defun make-speed-ast (child-ast value-ast &key origin)
  (make-instance 'speed-ast
    :origin origin
    :child-ast child-ast
    :value-asts value-ast))

Define new class SPEED-AST subclass of OPTIMIZE-AST.


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

(asdf:defsystem :cleavir-mir
  :depends-on (:cleavir-ir)
  :serial t
  :components
  ((:file "general")
   (:file "graphviz-drawing")))

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

(defsystem :cleavir-mir
  :depends-on (:cleavir-ir)
  :serial t
  :components
  ((:file "general")
   (:file "graphviz-drawing")))

Define ASDF system in package ASDF-USER.


(in-package #:jumpotron)

(defclass redirecting-jump (jump)
  ((target :initarg :target
           :initform (error "A jump needs a target")
           :reader target
           :documentation "FORMAT-string that will consume the words in the
query to construct a url to redirect the user to.")))

(defmethod jump ((jump redirecting-jump) query-parts)
  (redirect *response*
            (apply #'format nil (target jump) query-parts)))

(defun define-redirect (trigger format-string &optional (exclude-trigger-p t))
  "Defines a new redirecting jump. If a request comes in where a word in the
query is EQUAL to PREFIX, the user will be redirected to the result of calling
FORMAT with FORMAT-STRING and the words in the query. If EXCLUDE-TRIGGER-P is
NIL those words will also still contain TRIGGER.

This is equivalent to, and actually does, the following:

    (add-jump trigger
                (make-instance 'redirecting-jump
                               :target format-string
                               :exclude-trigger-p exclude-trigger-p))"
  (add-jump trigger
            (make-instance 'redirecting-jump
                           :target format-string
                           :exclude-trigger-p exclude-trigger-p)))

(in-package #:jumpotron)

(defclass redirecting-jump (jump)
  ((target :initarg :target
           :initform (error "A jump needs a target")
           :reader target
           :documentation "FORMAT-string that will consume the words in the
query to construct a url to redirect the user to.")))

(defmethod jump ((jump redirecting-jump) query-parts)
  (handler-case
      (redirect *response*
                (apply #'format nil (target jump) query-parts))
    (serious-condition () "You have an error in your query.")))

(defun define-redirect (trigger format-string &optional (exclude-trigger-p t))
  "Defines a new redirecting jump. If a request comes in where a word in the
query is EQUAL to PREFIX, the user will be redirected to the result of calling
FORMAT with FORMAT-STRING and the words in the query. If EXCLUDE-TRIGGER-P is
NIL those words will also still contain TRIGGER.

This is equivalent to, and actually does, the following:

    (add-jump trigger
                (make-instance 'redirecting-jump
                               :target format-string
                               :exclude-trigger-p exclude-trigger-p))"
  (add-jump trigger
            (make-instance 'redirecting-jump
                           :target format-string
                           :exclude-trigger-p exclude-trigger-p)))

Add some rough error handling to REDIRECTING-JUMP


(in-package #:method-combination-utilities)

(defun method-combination-expander-function (method-combination)
  #+ccl (cdr (ccl::method-combination-expander method-combination))
  #-ccl (error "this function is not available on ~A"
               (lisp-implementation-type)))

(defun method-combination-options (method-combination)
  #+ccl (ccl::method-combination-options method-combination)
  #-ccl (error "this function is not available on ~A"
               (lisp-implementation-type)))

(defmacro method-combination-expand (form)
  "Given a function call form, this returns the method-combination form that
   would be generated in the process of satisfying that call. This is only
   expected to work for functions whose method-combination was created using
   the long form of DEFINE-METHOD-COMBINATION.

   NOTE: This is currently CCL-only."
  (let* ((gf (symbol-function (car form)))
         (mc (generic-function-method-combination gf)))
    `(funcall ,(method-combination-expander-function mc)
              ,gf
              (compute-applicable-methods ,gf (list ,@(cdr form)))
              (method-combination-options ,mc))))

(in-package #:method-combination-utilities)

(defun method-combination-expander-function (method-combination)
  #+ccl (cdr (ccl::method-combination-expander method-combination))
  #+clisp (clos::method-combination-expander method-combination)
  #-(or ccl clisp)
  (error "this function is not available on ~A" (lisp-implementation-type)))

(defun method-combination-expansion-form (expander gf mc methods)
  #+ccl `(funcall ,expander ,gf ,methods ,(ccl::method-combination-options mc))
  #+clisp `(values (funcall ,expander
                            ,gf
                            ,mc
                            ,(clos::method-combination-options mc)
                            ,methods))
  #-(or ccl clisp)
  (error "this function is not available on ~A" (lisp-implementation-type)))

(defmacro method-combination-expand (form)
  "Given a function call form, this returns the method-combination form that
   would be generated in the process of satisfying that call. This is only
   expected to work for functions whose method-combination was created using
   the long form of DEFINE-METHOD-COMBINATION."
  (let* ((gf (symbol-function (car form)))
         (mc (generic-function-method-combination gf)))
    (method-combination-expansion-form (method-combination-expander-function mc)
                                       gf
                                       mc
                                       `(compute-applicable-methods
                                         ,gf
                                         (list ,@(cdr form))))))

Add CLISP support to METHOD-COMBINATION-EXPAND.


;;;; slime-helper.lisp

(defpackage #:quicklisp-slime-helper
  (:use #:cl)
  (:export #:install)
  (:shadowing-import-from #:alexandria
                          #:copy-file)
  (:shadowing-import-from #:ql-setup
                          #:qmerge))

(in-package #:quicklisp-slime-helper)

(defun install ()
  (let ((source (asdf:system-relative-pathname "quicklisp-slime-helper"
                                               "slime-helper-template"
                                               :type "el"))
        (target (qmerge "slime-helper.el")))
    (copy-file source target)
    (format t "~&slime-helper.el installed in ~S~%~%"
            (namestring target))
    (let ((enough (enough-namestring target (user-homedir-pathname))))
      (unless (equal (pathname enough) target)
        (setf enough (format nil "~~/~A" enough)))
      (format t "To use, add this to your ~~/.emacs:~%~%")
      (format t "  (load (expand-file-name ~S))~%" enough)
      (format t "  (require 'slime)~%~%"))))

;;;; slime-helper.lisp

(defpackage #:quicklisp-slime-helper
  (:use #:cl)
  (:export #:install)
  (:shadowing-import-from #:alexandria
                          #:copy-file)
  (:shadowing-import-from #:ql-dist
                          #:ensure-installed
                          #:find-system)
  (:shadowing-import-from #:ql-setup
                          #:qmerge))

(in-package #:quicklisp-slime-helper)

(defun install ()
  (let ((source (asdf:system-relative-pathname "quicklisp-slime-helper"
                                               "slime-helper-template"
                                               :type "el"))
        (target (qmerge "slime-helper.el")))
    (copy-file source target)
    (ensure-installed  (find-system "swank"))
    (format t "~&slime-helper.el installed in ~S~%~%"
            (namestring target))
    (let ((enough (enough-namestring target (user-homedir-pathname))))
      (unless (equal (pathname enough) target)
        (setf enough (format nil "~~/~A" enough)))
      (format t "To use, add this to your ~~/.emacs:~%~%")
      (format t "  (load (expand-file-name ~S))~%" enough)
      (format t "  (require 'slime)~%~%"))))

Use QL-DIST:ENSURE-INSTALLED to make sure quicklisp's slime is installed regardless of whether another swank is visible.


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

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

Load a file containing the definition of the class REAL-CLASS.


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

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

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

(asdf:defsystem :sicl-conditionals
  :depends-on (:cleavir-code-utilities)
  :serial t
  :components
  ((:file "packages")
   (:file "support")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "docstrings-en")
   (:file "macros")
   (:file "compiler-macros")))

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

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

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

(defsystem :sicl-conditionals
  :depends-on (:cleavir-code-utilities)
  :serial t
  :components
  ((:file "packages")
   (:file "support")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "docstrings-en")
   (:file "macros")
   (:file "compiler-macros")))


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

(defgeneric specialize (instruction implementation processor os))

(defun hir-to-mir (initial-instruction implementation processor os)
  ;; Gather up all instructions in a table
  (let ((table (make-hash-table :test #'eq)))
    (labels ((traverse (instruction)
	       (unless (gethash instruction table)
		 (setf (gethash instruction table) t)
		 (loop for succ in (cleavir-ir:successors instruction)
		       do (traverse succ))
		 (when (typep instruction 'cleavir-ir:enclose-instruction)
		   (traverse (cleavir-ir:code instruction))))))
      (traverse initial-instruction))
    ;; Appply specialize to all instructions in the table.
    (loop for instruction being each hash-key of table
	  do (specialize instruction implementation processor os))))

(defmethod specialize :around (instruction implementation processor os)
  (declare (ignorable implementation processor os))
  (let ((replacement (call-next-method)))
    (unless (eq instruction replacement)
      (setf (cleavir-ir:predecessors replacement)
	    (cleavir-ir:predecessors instruction))
      (loop for predecessor in (cleavir-ir:predecessors instruction)
	    do (nsubstitute replacement instruction
			    (cleavir-ir:successors predecessor))))))

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

(defgeneric specialize (instruction implementation processor os))

(defun hir-to-mir (initial-instruction implementation processor os)
  (let ((all-instructions '()))
    ;; Gather up all instructions in a list.
    (map-instructions
     (lambda (instruction)
       (push instruction all-instructions))
     initial-instruction)
    ;; Appply specialize to all instructions in the list.
    (loop for instruction in all-instructions
	  do (specialize instruction implementation processor os))))

(defmethod specialize :around (instruction implementation processor os)
  (declare (ignorable implementation processor os))
  (let ((replacement (call-next-method)))
    (unless (eq instruction replacement)
      (setf (cleavir-ir:predecessors replacement)
	    (cleavir-ir:predecessors instruction))
      (loop for predecessor in (cleavir-ir:predecessors instruction)
	    do (nsubstitute replacement instruction
			    (cleavir-ir:successors predecessor))))))

Make use of iterative mapping function.

Make use of iterative mapping function.


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

  :depends-on
  ("alexandria"
   "ucons"
   "priority-queue"
   "petalisp.utilities"
   "petalisp.core")

  :serial t
  :components
  ((:file "packages")
   (:file "device")
   (:file "ir")
   (:file "ir-checker")
   (:file "ir-conversion")
   (:file "blueprint")
   (:file "kernel-interpreter")
   (:file "kernel-compiler")
   (:file "ir-backend")
   (:file "documentation")))

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

  :depends-on
  ("alexandria"
   "ucons"
   "priority-queue"
   "split-sequence"
   "petalisp.utilities"
   "petalisp.core")

  :serial t
  :components
  ((:file "packages")
   (:file "device")
   (:file "ir")
   (:file "ir-checker")
   (:file "ir-conversion")
   (:file "blueprint")
   (:file "kernel-interpreter")
   (:file "kernel-compiler")
   (:file "ir-backend")
   (:file "documentation")))

Introduce missing dependency on split-sequence.


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

(defgeneric interpret-ast (ast static-env dynamic-env))

(defun interpret (ast)
  (let ((static-env (list (make-hash-table :test #'eq)))
	(dynamic-env '()))
    (interpret-ast ast static-env dynamic-env)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Methods on INTERPRET-AST.

(defmethod interpret-ast ((ast cleavir-ast:constant-ast)
			  static-env dynamic-env)
  (declare (ignore static-env dynamic-env))
  (cleavir-ast:value ast))

Define method on INTERPRET-AST specialized to CONSTANT-AST.


;;;; Depends on the MD5 library

(in-package :cleric)

(defun calculate-digest (challenge cookie)
  (md5:md5sum-string (format nil "~a~a" cookie challenge)))

;;;; Depends on the MD5 library

(in-package :cleric)

(defun calculate-digest (challenge cookie)
  (let ((input (format nil "~a~a" cookie challenge)))
    #+(or :cmu :sbcl (and :lispworks (not :lispworks4)) :ccl :allegro)
    (md5:md5sum-string input)
    #-(or :cmu :sbcl (and :lispworks (not :lispworks4)) :ccl :allegro)
    (md5:md5sum-sequence (map '(vector (unsigned-byte 8)) #'char-code input))))

Make CALCULATE-DIGEST work for all CL implementations.


(in-package :de.anvi.croatoan)

(defun add-string (window string &key y x n)
  "Add the unrendered string to the window.

If n is given, write at most n chars from the string. If n is -1, as
many chars will be added that will fit on the line.

If the coordinates y and x are given, move to the destination first
and then add the string."
  (let ((winptr (.winptr window)))
    (cond ((and y x n)
           (%mvwaddnstr winptr y x string n))
          ((and y x)
           (%mvwaddstr winptr y x string))
          (n
           (%waddnstr winptr string n))
          (t
           (%waddstr winptr string)))))

;;; TODOs

;; A common function to display both strings and chars.
;;(defun display (window object &key y x n)
;;  (if (typep object 'chtype)

;; rewrite all the addstr and print functions in a way that they use format internally and
;; can accept chars like ~% instead of C's \n.
;;(add-string scr (format nil " upper left corner~%~%~%"))

(in-package :de.anvi.croatoan)

;; first attempt to create add-string with attributes and colors
;; without adding a complex-string type first.
(defun add-string (window string &key attributes color-pair y x n)
  "Add the unrendered string to the window.

If n is given, write at most n chars from the string. If n is -1, as
many chars will be added that will fit on the line.

If the coordinates y and x are given, move to the destination first
and then add the string."
  (when (and y x) (move window y x))
  (let ((winptr (.winptr window))
        (pos1 (.cursor-position window)))
    (if n
        (%waddnstr winptr string n)
        (%waddstr winptr string))
    (when (or attributes color-pair)
      (let ((pos2 (.cursor-position window))
            (count (if n n (length string))))
        (move window (car pos1) (cadr pos1))
        (change-attributes window count attributes color-pair)
        (move window (car pos2) (cadr pos2))))))

;;; TODOs

;; A common function to display both strings and chars.
;;(defun display (window object &key y x n)
;;  (if (typep object 'chtype)

;; rewrite all the addstr and print functions in a way that they use format internally and
;; can accept chars like ~% instead of C's \n.
;;(add-string scr (format nil " upper left corner~%~%~%"))

Modify add-string to accept attributes and colors

Prelimitary change, uses %chgat internally, and cant display
attributes after a string is line wrapped.


(cl:in-package #:cleavir-simple-value-numbering)

;;; We attribute a unique number to each value designator.  That way,
;;; we can keep the value designators in a partition sorted by the
;;; unique number which makes operations on partitions faster.
;;;
;;; This variable should be bound to some small integer at the
;;; beginning of processing.
(defvar *unique-number*)

;;; We use instances of this class to designate values.
(defclass value-designator ()
  ((%unique-number :initform (incf *unique-number*) :reader unique-number)))

;;; This variable holds and EQ hash table mapping constants to value
;;; designators.
(defvar *constant-designators*)

(defun constant-designator (constant)
  (let ((result (gethash constant *constant-designators*)))
    (when (null result)
      (setf result (make-instance 'value-designator))
      (setf (gethash constant *constant-designators*) result))
    result))

(defun simple-value-numbering (initial-instruction)
  (declare (ignore initial-instruction))
  (let ((*unique-number* 0)
	(*constant-designators* (make-hash-table :test #'eq)))))

;;  LocalWords:  designator designators

(cl:in-package #:cleavir-simple-value-numbering)

;;; We use instances of this class to designate values.
(defclass value-designator ()
  ())

;;; This variable holds and EQ hash table mapping constants to value
;;; designators.
(defvar *constant-designators*)

(defun constant-designator (constant)
  (let ((result (gethash constant *constant-designators*)))
    (when (null result)
      (setf result (make-instance 'value-designator))
      (setf (gethash constant *constant-designators*) result))
    result))

(defun simple-value-numbering (initial-instruction)
  (declare (ignore initial-instruction))
  (let ((*constant-designators* (make-hash-table :test #'eq)))))

;;  LocalWords:  designator designators

Remove unique number. We will use a different technique.


;;;; cl-singleton-mixin.lisp
;;;;
;;;; Copyright 2015 hipeta (rhipeta@gmail.com)
;;;;
;;;; This software is released under the MIT License.
;;;; http://opensource.org/licenses/mit-license.php

(in-package :cl-user)
(defpackage cl-singleton-mixin
  (:use :cl)
  (:export :singleton-class
           :singleton-mixin
           :remove-singleton-instance))
(in-package :cl-singleton-mixin)

(defclass singleton-class (standard-class)
  ((%the-singleton-instance :initform nil)))
(defclass singleton-mixin () ())

(defmethod make-instance ((class singleton-class) &key)
  (with-slots (%the-singleton-instance) class
    (or %the-singleton-instance (setf %the-singleton-instance (call-next-method)))))

(defgeneric remove-singleton-instance (class)
  (:method ((class singleton-class))
    (with-slots (%the-singleton-instance) class
      (setf %the-singleton-instance nil))))

(defmethod reinitialize-instance :after ((class singleton-class) &key)
  (remove-singleton-instance class))

(metap:validate-superclass* (singleton-class standard-class t)
                            (singleton-class singleton-class t)
                            (standard-class singleton-class nil))
(metap:register-m1-m2-pair 'singleton-mixin 'singleton-class)

;;;; cl-singleton-mixin.lisp
;;;;
;;;; Copyright 2015 hipeta (rhipeta@gmail.com)
;;;;
;;;; This software is released under the MIT License.
;;;; http://opensource.org/licenses/mit-license.php

(in-package :cl-user)
(defpackage cl-singleton-mixin
  (:use :cl)
  (:export :singleton-class
           :singleton-mixin
           :remove-singleton-instance))
(in-package :cl-singleton-mixin)

(defclass singleton-class (standard-class)
  ((%the-singleton-instance :initform nil)))
(defclass singleton-mixin () ())

(defmethod make-instance ((class singleton-class) &key)
  (with-slots (%the-singleton-instance) class
    (or %the-singleton-instance (setf %the-singleton-instance (call-next-method)))))

(defgeneric remove-singleton-instance (class)
  (:method ((class symbol))
    (remove-singleton-instance (find-class class)))
  (:method ((class singleton-class))
    (with-slots (%the-singleton-instance) class
      (setf %the-singleton-instance nil))))

(defmethod reinitialize-instance :after ((class singleton-class) &key)
  (remove-singleton-instance class))

(metap:validate-superclass* (singleton-class standard-class t)
                            (singleton-class singleton-class t)
                            (standard-class singleton-class nil))
(metap:register-m1-m2-pair 'singleton-mixin 'singleton-class)

Add method remove-singleton-instance (class symbol)


;;;; packagedef.lisp
;;;; Author: Elliot Penson

(defpackage :knight-owl
  (:use :common-lisp))

;;;; packagedef.lisp
;;;; Author: Elliot Penson

(ql:quickload "cl-ppcre")

(defpackage :knight-owl
  (:use :common-lisp :cl-ppcre))

Use cl-ppcre in the knight-owl package

Use cl-ppcre in the knight-owl package


;;;; quickproject.asd

(asdf:defsystem #:quickproject
  :serial t
  :components ((:file "package")
               (:file "quickproject")))

;;;; quickproject.asd

(asdf:defsystem #:quickproject
  :description "Creates the skeleton of a new Common Lisp project"
  :serial t
  :components ((:file "package")
               (:file "quickproject")))

Add :description to system definition.

Add :description to system definition.


(in-package #:deb-package)

(ftype get-item list symbol list)
(defun get-item (list keyword)
  (rest
   (find-if #'(lambda (item)
                (getf item keyword))
            list)))

(defmacro define-deb-package (name &body forms)
  `(let ((name (string-downcase (symbol-name ',name)))
         (changelog-entries
          (make-array
           ,(length (get-item forms :changelog))
           :initial-contents (list ,@(mapcar
                                      #'(lambda (entry)
                                          `(make-instance 'changelog-entry ,@entry))
                                      (get-item forms :changelog))))))
     (format t "~A: ~A~%" name changelog-entries)))

(defclass changelog-entry ()
  ((version :initarg :version
            :type string
            :initform (error "Version required."))
   (author :initarg :author
           :type string
           :initform (error "Author required."))
   (message :initarg :message
            :type string
            :initform (error "Message required.")))
  (:documentation "A single changelog entry."))

(defclass deb-package ()
  ((changelog :initarg :changelog
              :type (vector changelog-entry)))
  (:documentation "Holds all the data required to generate a debian package."))

(in-package #:deb-package)

(ftype get-item list symbol list)
(defun get-item (list keyword)
  (rest
   (find-if #'(lambda (item)
                (getf item keyword))
            list)))

(defmacro define-deb-package (name &body forms)
  `(let ((changelog-entries
          (make-array
           ,(length (get-item forms :changelog))
           :initial-contents (list ,@(mapcar
                                      #'(lambda (entry)
                                          `(make-instance 'changelog-entry ,@entry))
                                      (get-item forms :changelog))))))
     (generate (make-instance 'deb-package
                              :name ',name
                              :changelog changelog-entries))))

(defclass changelog-entry ()
  ((version :initarg :version
            :type string
            :initform (error "Version required."))
   (author :initarg :author
           :type string
           :initform (error "Author required."))
   (message :initarg :message
            :type string
            :initform (error "Message required.")))
  (:documentation "A single changelog entry."))

(defclass deb-package ()
  ((name :initarg :name
         :type symbol
         :reader name
         :initform (error "Name required."))
   (changelog :initarg :changelog
              :type (vector changelog-entry)
              :reader changelog
              :initform (error "Changelog required.")))
  (:documentation "Holds all the data required to generate a debian package."))

(ftype generate deb-package null)
(defun generate (package)
  "Generates a debian package."
  (format t "~A: ~A"
          (string-downcase (symbol-name (name package)))
          (changelog package)))

Create the "generate" function and use it.


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

(defun fill-boot (boot)
  (customize-c1 boot)
  (customize-r1 boot)
  (phase1 boot)
  (customize-r2 boot)
  (customize-c2 boot)
  (phase2 boot)
  (phase3 boot))

(defmethod initialize-instance :after ((boot boot) &key &allow-other-keys)
  (fill-boot boot))

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

(defun fill-boot (boot)
  (customize-c1 boot)
  (customize-r2 boot)
  (phase1 boot)
  (phase2 boot)
  (phase3 boot))

(defmethod initialize-instance :after ((boot boot) &key &allow-other-keys)
  (fill-boot boot))

Reorder calls and remove calls that are no longer needed.


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

(env-load "transpiler/targets/javascript/config.lisp")
(env-load "transpiler/targets/javascript/expand.lisp")
;(env-load "transpiler/targets/javascript/class.lisp")
(env-load "transpiler/targets/javascript/codegen.lisp")
;(env-load "transpiler/targets/javascript/codegen-inline.lisp")
(env-load "transpiler/targets/javascript/codegen-inline-cons.lisp")
(env-load "transpiler/targets/javascript/env-load.lisp")
(env-load "transpiler/targets/javascript/toplevel.lisp")

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

(env-load "transpiler/targets/javascript/config.lisp")
(env-load "transpiler/targets/javascript/expand.lisp")
(env-load "transpiler/targets/javascript/class.lisp")
(env-load "transpiler/targets/javascript/codegen.lisp")
;(env-load "transpiler/targets/javascript/codegen-inline.lisp")
(env-load "transpiler/targets/javascript/codegen-inline-cons.lisp")
(env-load "transpiler/targets/javascript/env-load.lisp")
(env-load "transpiler/targets/javascript/toplevel.lisp")

Use class macros in this directory.

Use class macros in this directory.


(defsystem :named-readtables
  :description "Library that creates a namespace for named readtable akin to the namespace of packages."
  :author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
  :version "1.0"
  :licence "BSD"
  :serial t
  :components
  ((:file "package")
   (:file "destructure-case")
   (:file "cruft")
   (:file "named-readtables")))

(defsystem :named-readtables
  :description "Library that creates a namespace for named readtable akin to the namespace of packages."
  :author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
  :version "1.0 (unpublished so far)"
  :licence "BSD"
  :serial t
  :components
  ((:file "package")
   (:file "utils"            :depends-on ("package"))
   (:file "cruft"            :depends-on ("package" "utils"))
   (:file "named-readtables" :depends-on ("package" "utils" "cruft"))))

Add dependencies to DEFSYSTEM definition.

darcs-hash:20090426170432-f5546-a9312c05b5c28d26e1326659b4deccc02c7059ca.gz


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

(defun concat-stringtree (&rest x)
  (apply #'string-concat (tree-list x)))

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

(defun %concat-stringtree (x)
  (& x
     (? (string? x)
        x
        (apply #'string-concat (@ #'%concat-stringtree x)))))

(defun concat-stringtree (&rest x)
  (%concat-stringtree x))

CONCAT-STRINGTREE: Concatenate from leaves to root to use less heap.


(test-case 'test-case-qsort
           '((test test-qsort
                   ((assert-equal '() (qsort '()))
                    (assert-equal '(1) (qsort '(1)))
                    (assert-equal '(1 2) (qsort '(1 2)))
                    (assert-equal '(1 2 3) (qsort '(3 1 2)))
                    (assert-equal '(1 2 2 3) (qsort '(2 3 1 2)))))))

(test-case 'test-case-qsort
           '((test test-qsort-without-getter
                   ((assert-equal '() (qsort '()))
                    (assert-equal '(1) (qsort '(1)))
                    (assert-equal '(1 2) (qsort '(1 2)))
                    (assert-equal '(1 2 3) (qsort '(3 1 2)))
                    (assert-equal '(1 2 2 3) (qsort '(2 3 1 2)))))
             (test test-qsort-with-getter
                   ((assert-equal '((1 . 4) (2 . 3)) (qsort '((2 . 3) (1 . 4)) car))
                    (assert-equal '((2 . 3) (1 . 4)) (qsort '((1 . 4) (2 . 3)) cdr))))))

Test qsort with and without getter

Test qsort with and without getter


(in-package #:cl-user)

(asdf:defsystem :sicl-loop-test
  :depends-on (:sicl-loop-support)
  :serial t
  :components
  ((:file "test-packages")
   (:file "loop-defmacro")
   (:file "loop-test")
   (:file "simple-loop")
   (:file "loop1")
   (:file "loop2")
   (:file "loop3")
   (:file "loop4")
   (:file "loop5")
   (:file "loop6")
   (:file "loop7")
   (:file "loop8")
   (:file "loop9")
   (:file "loop10")
   (:file "loop11")
   (:file "loop12")
   (:file "loop13")
   (:file "loop14")
   (:file "loop15")
   (:file "loop16")
   (:file "loop17")))

(in-package #:asdf-user)

(defsystem :sicl-loop-test
  :depends-on (:sicl-loop-support)
  :serial t
  :components
  ((:file "test-packages")
   (:file "loop-defmacro")
   (:file "loop-test")
   (:file "simple-loop")
   (:file "loop1")
   (:file "loop2")
   (:file "loop3")
   (:file "loop4")
   (:file "loop5")
   (:file "loop6")
   (:file "loop7")
   (:file "loop8")
   (:file "loop9")
   (:file "loop10")
   (:file "loop11")
   (:file "loop12")
   (:file "loop13")
   (:file "loop14")
   (:file "loop15")
   (:file "loop16")
   (:file "loop17")))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


(eval-when (:compile-toplevel :load-toplevel)
  (ql:quickload 'docutils))

(defpackage :coleslaw-rst
  (:use :cl)
  (:import-from :coleslaw #:render-content)
  (:import-from :cl-docutils #:read-rst
                             #:write-html)
  (:export #:enable))

(in-package :coleslaw-rst)

(defmethod render-content (text (format (eql :rst)))
  (with-output-to-string (str)
    (write-html str (read-rst text))))

(defun enable ())

(eval-when (:compile-toplevel :load-toplevel)
  (ql:quickload 'docutils))

(defpackage :coleslaw-rst
  (:use :cl)
  (:import-from :coleslaw #:render-content)
  (:import-from :docutils #:read-rst
                          #:write-html)
  (:export #:enable))

(in-package :coleslaw-rst)

(defmethod render-content (text (format (eql :rst)))
  (with-output-to-string (str)
    (write-html str (read-rst text))))

(defun enable ())

Package fix to rst plugin.

Package fix to rst plugin.


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

(defconstant nil 'nil)
(defconstant t 't)

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

(defconstant nil 'nil)
(defconstant t 't)

Use explicit package marker with IN-PACKAGE.


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

(defgeneric rotate-left (tree))

(defgeneric rotate-right (tree))

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

Add method on ROTATE-LEFT specialized to NODE.


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

(asdf:defsystem cleavir-code-utilities
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "argcount")
   (:file "form")
   (:file "general")
   (:file "declarations")
   (:file "lambda-lists")
   (:file "destructuring")))

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

(asdf:defsystem cleavir-code-utilities
  :depends-on (:cleavir-internationalization)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "argcount")
   (:file "form")
   (:file "general")
   (:file "declarations")
   (:file "lambda-lists")
   (:file "destructuring")))

Make the system depend on the internationalization system.


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

(defun butlast-path-component (x)
  (apply #'+ (pad (butlast (path-pathlist x)) "/")))

(defun url-without-filename (x)
  (? x
     (butlast-path-component x)
	 ""))

(defun url-schema (x)
  (car (split #\/ x)))

(defun url-has-schema? (x)
  (alet (split #\/ x)
    (& (tail? !. ":")
	   (empty-string? .!.))))

(defun url-without-schema (x)
  (? (url-has-schema? x)
     (subseq x (+ 2 (length (url-schema x))))
     x))

(defun url-path (x)
  (& x (apply #'+ (pad (cdr (path-pathlist (url-without-schema x))) "/"))))

(defun url-without-path (x)
  (apply #'+ (pad (subseq (path-pathlist x) 0 3) "/")))

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

(defun butlast-path-component (x)
  (pathlist-path (pad (butlast (path-pathlist x)) "/")))

(defun url-without-filename (x)
  (? x
     (butlast-path-component x)
	 ""))

(defun url-schema (x)
  (car (path-pathlist x)))

(defun url-has-schema? (x)
  (alet (path-pathlist x)
    (& (tail? !. ":")
	   (empty-string? .!.))))

(defun url-without-schema (x)
  (? (url-has-schema? x)
     (subseq x (+ 2 (length (url-schema x))))
     x))

(defun url-path (x)
  (pathlist-path (pad (cdr (path-pathlist (url-without-schema x))) "/")))

(defun url-without-path (x)
  (pathlist-path (pad (subseq (path-pathlist x) 0 3) "/")))

Use PATHLIST-PATH to deal with empty names.


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

(defun customize-r2 (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (define-make-instance boot)
    (define-direct-slot-definition-class boot)
    (define-find-class boot)
    (ld "../CLOS/ensure-generic-function-using-class-support.lisp" c r)))

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

(defun define-validate-superclass (boot)
  (setf (sicl-genv:fdefinition 'sicl-clos:validate-superclass (r2 boot))
	(constantly t)))

(defun customize-r2 (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (define-make-instance boot)
    (define-direct-slot-definition-class boot)
    (define-find-class boot)
    (define-validate-superclass boot)
    (ld "../CLOS/ensure-generic-function-using-class-support.lisp" c r)))

Define function VALIDATE-SUPERCLASS in run-time environment R2, always returning true.


(in-package #:asdf-user)

(defsystem #:sicl-additional-types
  :components
  ((:file "packages")
   (:file "types" :depends-on ("packages"))))

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

(defsystem #:sicl-additional-types
  :components
  ((:file "packages")
   (:file "types" :depends-on ("packages"))))

Use explicit package prefix for IN-PACKAGE.


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

(defun create-bridge-class-accessors (boot)
  (let ((c (c2 boot))
	(r (r3 boot)))
  (ld "../CLOS/method-function-defgeneric.lisp" c r)))

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

(defun create-bridge-class-accessors (boot)
  (let ((c (c2 boot))
	(r (r3 boot)))
  (ld "../CLOS/method-function-defgeneric.lisp" c r)
  (ld "../CLOS/method-generic-function-defgeneric.lisp" c r)
  (ld "../CLOS/method-lambda-list-defgeneric.lisp" c r)
  (ld "../CLOS/method-qualifiers-defgeneric.lisp" c r)
  (ld "../CLOS/method-specializers-defgeneric.lisp" c r)
  (ld "../CLOS/accessor-method-slot-definition-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-name-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-allocation-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-type-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-initargs-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-initform-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-initfunction-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-readers-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-writers-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-location-defgeneric.lisp" c r)
  (ld "../CLOS/class-name-defgeneric.lisp" c r)
  (ld "../CLOS/class-direct-superclasses-defgeneric.lisp" c r)
  (ld "../CLOS/class-direct-slots-defgeneric.lisp" c r)
  (ld "../CLOS/class-direct-default-initargs-defgeneric.lisp" c r)
  (ld "../CLOS/class-precedence-list-defgeneric.lisp" c r)
  (ld "../CLOS/class-slots-defgeneric.lisp" c r)
  (ld "../CLOS/class-default-initargs-defgeneric.lisp" c r)
  (ld "../CLOS/class-finalized-p-defgeneric.lisp" c r)
  (ld "../CLOS/class-prototype-defgeneric.lisp" c r)))

Load more files containing definitions of class accessors.


(in-package #:asdf-user)

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

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

(defsystem :sicl-cons-high
  :depends-on (:cleavir-internationalization)
  :serial t
  :components
  ((:file "packages")
   (:file "cons-high")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))

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

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

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

(defsystem :sicl-cons-high
  :depends-on (:cleavir-internationalization)
  :serial t
  :components
  ((:file "packages")
   (:file "cons-high")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))


(in-package :cl-user)
(uiop/package:define-package :clutils/all
    (:nicknames :clutils)
  (:use :cl)
  (:use-reexport
   :clutils/functional
   :clutils/math
   :clutils/strings
   :clutils/macros
   :clutils/lists
   :clutils/sequences
   :clutils/packages
   :clutils/project))

(in-package :cl-user)
(uiop/package:define-package :clutils/all
    (:nicknames :clutils :clu)
  (:use :cl)
  (:use-reexport
   :clutils/functional
   :clutils/math
   :clutils/strings
   :clutils/macros
   :clutils/lists
   :clutils/sequences
   :clutils/packages
   :clutils/project))

Add package nickname :clu as shortcut.

Add package nickname :clu as shortcut.


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

(asdf:defsystem #:sicl-hir-to-mir
  :depends-on (:cleavir-hir-to-mir
	       :cleavir-processor-x86-64
	       :sicl-target-sicl)
  :serial t
  :components
  ((:file "packages")
   (:file "general")
   (:file "cons")
   (:file "integer")
   (:file "environment-related-instructions")))

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

(defsystem #:sicl-hir-to-mir
  :depends-on (:cleavir-hir-to-mir
	       :cleavir-processor-x86-64
	       :sicl-target-sicl)
  :serial t
  :components
  ((:file "packages")
   (:file "general")
   (:file "cons")
   (:file "integer")
   (:file "environment-related-instructions")))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*-

(asdf:defsystem glop
  :license "MIT"
  :version "git"
  :description "Direct FFI bindings for OpenGL window and context management"
  :author "Morgan Veyret <patzy at appart kicks-ass net>"
  :depends-on (:cffi)
  :components
  ((:module "src"
            :serial t
            :components
            ((:file "package")
             (:file "utils")
             #+unix(:module "x11"
                            :serial t
                            :components ((:file "package")
                                         (:file "keysymdef")
                                         (:file "xlib")
                                         (:file "xkb")
                                         (:file "glx")
                                         (:file "display-ctrl")
                                         (:file "glop-x11")))
             #+(or win32 windows)(:module "win32"
                                          :serial t
                                          :components ((:file "package")
                                                       (:file "win32")
                                                       (:file "wgl")
                                                       (:file "glop-win32")))
             (:file "glop")))))

;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*-

(asdf:defsystem glop
  :license "MIT"
  :version "0.1.0"
  :description "Direct FFI bindings for OpenGL window and context management"
  :author "Morgan Veyret <patzy at oxyde dot org>"
  :depends-on (:cffi)
  :components
  ((:module "src"
            :serial t
            :components
            ((:file "package")
             (:file "utils")
             #+unix(:module "x11"
                            :serial t
                            :components ((:file "package")
                                         (:file "keysymdef")
                                         (:file "xlib")
                                         (:file "xkb")
                                         (:file "glx")
                                         (:file "display-ctrl")
                                         (:file "glop-x11")))
             #+(or win32 windows)(:module "win32"
                                          :serial t
                                          :components ((:file "package")
                                                       (:file "win32")
                                                       (:file "wgl")
                                                       (:file "glop-win32")))
             (:file "glop")))))

Fix invalid asdf version string and contact email


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

(defclass tree ()
  ((%contents :initform nil :accessor contents)))

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

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

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

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

Define new class 3-NODE for the nodes with 3 children of the 2-3 tree.


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

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

(defclass slot-definition (metaobject)
  ((%name
    :initarg :name
    :reader slot-definition-name)
   (%allocation
    :initarg :allocation
    :initform :instance
    :reader slot-definition-allocation)
   (%type
    :initarg :type
    :initform t
    :reader slot-definition-type)
   (%initargs
    :initform '()
    :initarg :initargs
    :reader slot-definition-initargs)
   (%initform
    :initarg :initform
    :initform nil
    :reader slot-definition-initform)
   (%initfunction
    :initform nil
    :initarg :initfunction
    :reader slot-definition-initfunction)))

Add copyright dates and license statement.


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

(in-package :cl-user)
(uiop:define-package download-manager/tests
  (:use #:common-lisp #:prove)
  (:import-from #:download-manager))
(in-package :download-manager/tests)

(plan nil)

(subtest "Simple HTTP/HTTPS downloads"
  (let ((urls '("https://abcl.org"
                "http://en.wikipedia.org/wiki/Main_Page"
                "https://duckduckgo.com"
                "https://atlas.engineer")))
    (dolist (url urls)
      (ok
       (download-manager:resolve (quri:uri url))
       (format nil "Able to download <~a>~%" url)))))

(finalize)

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

(in-package :cl-user)
(uiop:define-package download-manager/tests
  (:use #:common-lisp #:prove)
  (:import-from #:download-manager))
(in-package :download-manager/tests)

(plan nil)

(subtest "Simple HTTP/HTTPS downloads"
  (let ((urls '("https://abcl.org"
                "http://en.wikipedia.org/wiki/Main_Page"
                "https://duckduckgo.com"
                "https://nyxt.atlas.engineer")))
    (dolist (url urls)
      (ok
       (download-manager:resolve (quri:uri url))
       (format nil "Able to download <~a>~%" url)))))

(finalize)

libraries/download-manager: Use Nyxt specific site instead of Atlas.

It's more frequently used, so in case the certificate expires, we are more
likely to notice it.
Plus it's more related to Nyxt.


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

;;; The method defined here is meant to implement the behavior
;;; described in "Initialization of Method Metaobjects" in the AMOP.

;;; FIXME: Here, I specialize on METHOD, but check whether the
;;; specialization should be reserved for STANDARD-METHOD instead.

(defmethod initialize-instance :after ((method method)
				       &rest keys
				       &key
					 qualifiers
					 lambda-list
					 specializers
					 function
					 documentation)
  (declare (ignore qualifiers lambda-list specializers function documentation))
  (apply #'initialize-instance-after-method method keys))

(defmethod initialize-instance :after ((method standard-accessor-method)
				       &rest keys
				       &key
					 slot-definition
				       &allow-other-keys)
  (declare (ignore slot-definition))
  (apply #'initialize-instance-after-standard-accessor-method method keys))

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

;;; The method defined here is meant to implement the behavior
;;; described in "Initialization of Method Metaobjects" in the AMOP.

;;; FIXME: Here, I specialize on METHOD, but check whether the
;;; specialization should be reserved for STANDARD-METHOD instead.

(defmethod initialize-instance :after ((method method)
				       &rest keys
				       &key
					 qualifiers
					 lambda-list
					 specializers
					 function
					 documentation
				       &allow-other-keys)
  (declare (ignore qualifiers lambda-list specializers function documentation))
  (apply #'initialize-instance-after-method method keys))

(defmethod initialize-instance :after ((method standard-accessor-method)
				       &rest keys
				       &key
					 slot-definition
				       &allow-other-keys)
  (declare (ignore slot-definition))
  (apply #'initialize-instance-after-standard-accessor-method method keys))

Allow for :SLOT-DEFINITION initarg by adding &allow-other-keys.


(in-package #:sicl-clos)

(define-built-in-class sequence (t)
  ())

(define-built-in-class list (sequence)
  ())

(define-built-in-class symbol ()
  ((%name :initarg :name :reader symbol-name)
   (%package :initarg :package :reader symbol-package)))

(define-built-in-class null (symbol list)
  ())

(in-package #:sicl-clos)

;;; We need for funcallable standard objects and standard functions to
;;; be called the same way.  There is a slight difficulty in order for
;;; that to happen, though.  When a funcallable standard object is
;;; allocated, since it is a standard object, two additional cells are
;;; allocated in the contents vector, namely for the object class
;;; unique number and for the class slots of the class.  When a
;;; standard function is allocated, however, the cell containing the
;;; class slots of the class is not present because standard functions
;;; are not standard objects, so they can not become obsolete, and
;;; therefore do not need this information in order to be updated.
;;; But we still want the slots of the FUNCTION class to have the same
;;; location in instances of STANDARD-FUNCTION.  To accomplish that,
;;; we add a dummy slot to standard functions that is in the same
;;; location as the class slots of the class in standard objects.  To
;;; add this dummy slot, we define a class DUMMY-SLOT-PROVIDER,
;;; containing such a slot.

(define-built-in-class dummy-slot-supplier (t)
  ((%dummy :initform nil)))

;;; It is important that the list of superclasses appear in the order
;;; that it does in this definition, because slots are allocated with
;;; locations that take this order into account.  In this case, the
;;; slot supplied by DUMMY-SLOT-SUPPLIER will occupy the first
;;; location in instances of STANDARD-FUNCTION.
(define-built-in-class standard-function (dummy-slot-supplier function)
  ())

(define-built-in-class sequence (t)
  ())

(define-built-in-class list (sequence)
  ())

(define-built-in-class symbol ()
  ((%name :initarg :name :reader symbol-name)
   (%package :initarg :package :reader symbol-package)))

(define-built-in-class null (symbol list)
  ())

Define STANDARD-FUNCTION and explain why it is defined that way in comment.


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

(asdf:defsystem :sicl-type
  :components
  ((:file "packages")))

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

(defsystem :sicl-type
  :components
  ((:file "packages")))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


;;;; package.lisp

(defpackage #:sdl2
  (:use #:cl #:alexandria #:cffi)
  (:export :sys-video
           :sys-audio
           :sys-timer
           :sys-joystick
           :sys-gamecontroller ; implies joystick
           :noparachute
           :everything
           :init
           :quit
           :create-window
           :destroy-window))

(defpackage #:sdl2-ffi)

;;;; package.lisp

(defpackage #:sdl2
  (:use #:cl #:alexandria #:cffi)
  (:export ;; API
           #:init
           #:quit
           #:create-window
           #:destroy-window

           ;; Conditions
           #:sdl-error))

(defpackage #:sdl2-ffi)

Remove some now-spurious exports, export conditions, use uninterned symbols


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

(asdf:defsystem :sicl-read
    :components
  ((:file "packages" :depends-on ())
   (:file "float" :depends-on ("packages"))
   (:file "read" :depends-on ("packages" "float"))))

(in-package #:asdf-user)

(defsystem :sicl-read
    :components
  ((:file "packages" :depends-on ())
   (:file "float" :depends-on ("packages"))
   (:file "read" :depends-on ("packages" "float"))))

Define ASDF system in package ASDF-USER.


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

(defsystem monkeylib-markup-xml
  :name "monkeylib-markup-xml"
  :components
  ((:file "packages")
   (:file "xml" :depends-on ("packages")))
  :depends-on
  (:com.gigamonkeys.macro-utilities
   :com.gigamonkeys.utilities
   :com.gigamonkeys.foo))

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

(defsystem monkeylib-markup-xml
  :name "monkeylib-markup-xml"
  :description "Library for generating XML from Markup-formatted text."
  :components
  ((:file "packages")
   (:file "xml" :depends-on ("packages")))
  :depends-on
  (:com.gigamonkeys.macro-utilities
   :com.gigamonkeys.utilities
   :com.gigamonkeys.foo))

Add description to .asd file.

Add description to .asd file.


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

(defun load-file (filename environment)
  (load-source-with-environments
   (asdf:system-relative-pathname :sicl-extrinsic-hir-compiler filename)
   environment
   environment))

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

(defun load-file (filename environment)
  (load-source-with-environments
   (asdf:system-relative-pathname :sicl-extrinsic-environment filename)
   environment
   environment))

Replace ASDF system used for relative pathnames.


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

(defun tre-expansions (x)
  (backquote-expand (quasiquote-expand (macroexpand (dot-expand x)))))
(defun expr2cl (x)                 (make-lambdas (tre-expansions x)))
(defun file2cl (pathname)          (expr2cl (read-file pathname)))
(defun files2cl (&rest pathnames)  (. 'progn (mapcan #'file2cl pathnames)))

(defun cl-expex-initializer (ex)
  (= (expex-argument-filter ex) #'identity
     (expex-setter-filter ex)   #'identity))

(defun cl-frontend (x)
  (alet (transpiler-macroexpand (quasiquote-expand (dot-expand x)))
    (fake-expression-expand (fake-place-expand (lambda-expand (rename-arguments (backquote-expand (compiler-macroexpand !))))))
    (make-lambdas !)))

(defun cl-sections-before-deps ()
  (unless (exclude-base?)
    (list (. 'cl-base *cl-base*))))

(defun make-cl-transpiler ()
  (create-transpiler
      :name                  :common-lisp
      :frontend-only?        t
      :import-variables?     t
      :lambda-export?        nil
      :stack-locals?         nil
      :sections-before-deps  #'cl-sections-before-deps
      :frontend-init         #'(() (= *cl-builtins* nil))
      :own-frontend          #'cl-frontend
      :expex-initializer     #'cl-expex-initializer))

(defvar *cl-transpiler* (copy-transpiler (make-cl-transpiler)))

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

(defun cl-expex-initializer (ex)
  (= (expex-argument-filter ex) #'identity
     (expex-setter-filter ex)   #'identity))

(defun cl-frontend (x)
  (aprog1 (transpiler-macroexpand (quasiquote-expand (dot-expand x)))
    (fake-expression-expand (fake-place-expand (lambda-expand (rename-arguments (backquote-expand (compiler-macroexpand !))))))))

(defun cl-sections-before-deps ()
  (unless (exclude-base?)
    (list (. 'cl-base *cl-base*))))

(defun make-cl-transpiler ()
  (create-transpiler
      :name                  :common-lisp
      :frontend-only?        t
      :import-variables?     t
      :lambda-export?        nil
      :stack-locals?         nil
      :sections-before-deps  #'cl-sections-before-deps
      :frontend-init         #'(() (= *cl-builtins* nil))
      :own-frontend          #'cl-frontend
      :expex-initializer     #'cl-expex-initializer
      :postprocessor         #'((&rest x)
                                  (make-lambdas (apply #'+ x)))))

(defvar *cl-transpiler* (copy-transpiler (make-cl-transpiler)))

Make lambda exoression in (POSTPROCESSOR).


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

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

(defun create-bridge-classes (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (ld "../CLOS/t-defclass.lisp" c r)
    (ld "../CLOS/standard-object-defclass.lisp" c r)
    (ld "../CLOS/metaobject-defclass.lisp" c r)
    (ld "../CLOS/method-combination-defclass.lisp" c r)
    (ld "../CLOS/slot-definition-defclass.lisp" c r)
    (ld "../CLOS/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 SLOT-DEFINITION.


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

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

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

Load new file with definition of ENSURE-GENERIC-FUNCTION.


(in-package :local-time-locale)

(defmethod make-locale ((class (eql :pt-bz)))
  (make-instance 'locale-pt
		 :first-day-of-week 0))

(in-package :local-time-locale)

(defmethod make-locale ((class (eql :pt-br)))
  (make-instance 'locale-pt
		 :first-day-of-week 0))

Complete the renameing of brazilian portuguese


;;;; cl-singleton-mixin.lisp
;;;;
;;;; Copyright 2015 hipeta (rhipeta@gmail.com)
;;;;
;;;; This software is released under the MIT License.
;;;; http://opensource.org/licenses/mit-license.php

(in-package :cl-user)
(defpackage cl-singleton-mixin
  (:use :cl)
  (:export :singleton-class
           :singleton-mixin
           :remove-singleton-instance))
(in-package :cl-singleton-mixin)

(defclass singleton-class (standard-class)
  ((%the-singleton-instance :initform nil)))
(defclass singleton-mixin () ())

(defmethod make-instance :around ((class singleton-class) &key)
  (with-slots (%the-singleton-instance) class
    (or %the-singleton-instance (setf %the-singleton-instance (call-next-method)))))

(defgeneric remove-singleton-instance (class)
  (:method ((class symbol))
    (remove-singleton-instance (find-class class)))
  (:method ((class singleton-class))
    (with-slots (%the-singleton-instance) class
      (setf %the-singleton-instance nil))))

(defmethod reinitialize-instance :after ((class singleton-class) &key)
  (remove-singleton-instance class))

(metap:validate-superclass* (singleton-class standard-class t)
                            (singleton-class singleton-class t)
                            (standard-class singleton-class nil))

(metap:register-m1-m2-pair singleton-mixin singleton-class)

;;;; cl-singleton-mixin.lisp
;;;;
;;;; Copyright 2015 hipeta (rhipeta@gmail.com)
;;;;
;;;; This software is released under the MIT License.
;;;; http://opensource.org/licenses/mit-license.php

(in-package :cl-user)
(defpackage cl-singleton-mixin
  (:use :cl)
  (:export :singleton-class
           :singleton-mixin
           :remove-singleton-instance))
(in-package :cl-singleton-mixin)

(defclass singleton-class (standard-class)
  ((%the-singleton-instance :initform nil)))
(defclass singleton-mixin () ())

(defmethod make-instance :around ((class singleton-class) &key)
  (with-slots (%the-singleton-instance) class
    (or %the-singleton-instance (setf %the-singleton-instance (call-next-method)))))

(defgeneric remove-singleton-instance (class)
  (:method ((class symbol))
    (remove-singleton-instance (find-class class)))
  (:method ((class singleton-class))
    (with-slots (%the-singleton-instance) class
      (setf %the-singleton-instance nil))))

(defmethod reinitialize-instance :after ((class singleton-class) &key)
  (remove-singleton-instance class))

(metap:validate-superclass* (singleton-class standard-class t)
                            (singleton-class singleton-class t)
                            (standard-class singleton-class nil))

(metap:register-m1-m2-pair 'singleton-mixin 'singleton-class)

Modify some code for metap changed

Modify some code for metap changed


;;; -*- Mode: Lisp; package: CL-USER; Syntax: Common-lisp; Base: 10 -*-

#|

|#

(in-package #:common-lisp-user)
(defpackage #:cl-markdown-test-system (:use #:cl #:asdf))
(in-package #:cl-markdown-test-system)

(defsystem cl-markdown-test
  :version "0.1"
  :author "Gary Warren King <gwking@metabang.com>"
  :maintainer "Gary Warren King <gwking@metabang.com>"
  :licence "MIT Style License"
  :components ((:module "unit-tests"
                        :components ((:file "package")
                                     (:file "framework"
                                            :depends-on ("package"))
                                     (:file "comparison"
                                            :depends-on ("framework"))
                                     (:file "test-markdown"
                                            :depends-on ("package"))
                                     (:file "test-chunkers"
                                            :depends-on ("test-markdown"))
                                     (:file "test-regexes"
                                            :depends-on ("test-spans"))
                                     (:file "test-spans"
                                            :depends-on ("test-markdown"))
                                     (:file "test-strippers"
                                            :depends-on ("test-markdown")))))

  :depends-on (cl-markdown lml2 lift cl-html-diff html-encode trivial-shell))

;;; -*- Mode: Lisp; package: CL-USER; Syntax: Common-lisp; Base: 10 -*-

(in-package #:common-lisp-user)
(defpackage #:cl-markdown-test-system (:use #:cl #:asdf))
(in-package #:cl-markdown-test-system)

(defsystem cl-markdown-test
  :version "0.1"
  :author "Gary Warren King <gwking@metabang.com>"
  :maintainer "Gary Warren King <gwking@metabang.com>"
  :licence "MIT Style License"
  :components ((:module "unit-tests"
                        :components ((:file "package")
				     (:file "test-markdown"
                                            :depends-on ("package"))
                                     (:file "test-chunkers"
                                            :depends-on ("test-markdown"))
                                     (:file "test-regexes"
                                            :depends-on ("test-spans"))
                                     (:file "test-spans"
                                            :depends-on ("test-markdown"))
                                     (:file "test-strippers"
                                            :depends-on ("test-markdown")))))
  :depends-on (cl-markdown lift))

Split tests into tests and create comparison report

darcs-hash:20060925005623-3cc5d-c1498fe15c016b82881c0ab84c821ed053b3d098.gz


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

  :depends-on ()

  :serial t
  :components
  ((:file "packages")
   (:file "identical")
   (:file "memoization")
   (:file "extended-euclid")
   (:file "define-method-pair")
   (:file "define-class-predicate")
   (:file "defalias")))

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

  :depends-on ("alexandria")

  :serial t
  :components
  ((:file "packages")
   (:file "identical")
   (:file "memoization")
   (:file "extended-euclid")
   (:file "define-method-pair")
   (:file "define-class-predicate")
   (:file "defalias")))

Make petalisp.utilties depend on alexandria.


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

(defvar *tre-revision*
    ,(with-open-file in (open "_current-version" :direction 'input)
       (let l (string-list (read-line in))
         (list-string (subseq l
                              (!? (position #\: l)
                                  (1+ !)
                                  0)
                              (1- (length l)))))))

(format t "; Revision ~A.~%" *tre-revision*)

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

(defvar *tre-revision*
    ,(with-open-file in (open "_current-version" :direction 'input)
       (let l (string-list (read-line in))
         (list-string
           (alet (subseq l
                         (!? (position #\: l)
                             (1+ !)
                             0)
                         (1- (length l)))
             (? (== #\M (car (last !)))
                (butlast !)
                !))))))

(format t "; Revision ~A.~%" *tre-revision*)

Remove "M" from revision number.

Remove "M" from revision number.


(in-package :cl-user)
(defpackage :nellie.alists
  (:use :cl)
  (:nicknames #:alists)
  (:export #:alist-get
           #:alist-get-str
           #:alist-set
           #:alist-update
           #:alist-merge))

(in-package :nellie.alists)

(defun alist-get (key alist)
  (cdr (assoc key alist)))

(defun alist-get-str (str-key alist)
  (cdr (assoc str-key alist :test #'equal)))

(defun alist-set (key value alist &key (test #'eql))
  (let ((existing (assoc key alist :test test)))
    (if existing
        (rplacd existing value)
        (rplacd (last alist) `((,key . ,value))))
    alist))

(defun alist-update (al1 al2 &key (test #'eql))
  (dolist (kv al2)
    (alist-set (car kv) (cdr kv) al1 :test test))
  al1)

(defun alist-merge (alists &key (test #'eql))
  (reduce (lambda (a b) (alist-update a b :test test))
          (cdr alists)
          :initial-value (copy-alist (car alists))))

(in-package :cl-user)
(defpackage :nellie.alists
  (:use :cl)
  (:nicknames #:alists)
  (:export #:alist-get
           #:alist-get-str
           #:alist-set
           #:alist-update
           #:alist-merge))

(in-package :nellie.alists)

(defun alist-get (alist key &key (test #'eql))
  (cdr (assoc key alist :test test)))

(defun alist-get-str (alist key-string)
  (cdr (assoc key-string alist :test #'equal)))

(defun alist-set (alist key value &key (test #'eql))
  (if (null alist)
      (list (cons key value))
      (let ((existing (assoc key alist :test test)))
        (if existing
            (rplacd existing value)
            (rplacd (last alist) (list (cons key value))))
        alist)))

(defun alist-update (alist updates-alist &key (test #'eql))
  (dolist (kv updates-alist)
    (setf alist (alist-set alist (car kv) (cdr kv) :test test)))
  alist)

(defun alist-merge (alists &key (test #'eql))
  (reduce (lambda (a b) (alist-update a b :test test)) alists))

Make `alist` the first parameter of all the alist handling functions


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

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

(defun fill-environment (environment)
  (sicl-genv:fmakunbound 'sicl-clos:ensure-generic-function-using-class
			 environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment)
  (setf (sicl-genv:find-class 'standard-object environment) nil)
  (ld "../../CLOS/standard-object-defclass.lisp" environment))

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

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

(defun fill-environment (environment)
  (sicl-genv:fmakunbound 'sicl-clos:ensure-generic-function-using-class
			 environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment)
  (setf (sicl-genv:find-class 'standard-object environment) nil)
  (ld "../../CLOS/standard-object-defclass.lisp" environment)
  (setf (sicl-genv:find-class 'sicl-clos:metaobject environment) nil)
  (ld "../../CLOS/metaobject-defclass.lisp" environment))

Load file containing definition of class METAOBJECT.


;;;; tutorial-builder.asd

(asdf:defsystem #:tutorial-builder
  :serial t
  :description "A library for presenting md files as tutorials."
  :author "Matt Niemeir <matt.niemeir@gmail.com>"
  :license "BSD 2-clause"
  :depends-on (#:lazy-susan
               #:dishes
               #:uiop
               #:alexandria
               #:3bmd
               )
  :components ((:file "package")
               (:file "utils.lisp")
               (:file "tutorial-builder")))

;;;; tutorial-builder.asd

(asdf:defsystem #:tutorial-builder
  :serial t
  :description "A library for presenting md files as tutorials."
  :author "Matt Niemeir <matt.niemeir@gmail.com>"
  :license "BSD 2-clause"
  :depends-on (#:lazy-susan
               #:dishes
               #:uiop
               #:alexandria
               #:3bmd
               )
  :components ((:file "package")
               (:file "utils")
               (:file "tutorial-builder")))

Fix name of utils.lisp in the asd

Fix name of utils.lisp in the asd


(asdf:defsystem cl-rfc3339
    :author "Gregory Tod <lisp@gtod.net>"
    :version "0.1.0"
    :license "MIT"
    :description "Canonicalize time formats to a specifc RFC 3339 compliant string."
    :depends-on (#:local-time)
    :components ((:file "package")
                 (:file "rfc3339")))

(asdf:defsystem cl-rfc3339
    :author "Gregory Tod <lisp@gtod.net>"
    :version "0.1.0"
    :license "MIT"
    :description "Canonicalize time formats to a specific RFC 3339 compliant string."
    :depends-on (#:local-time)
    :components ((:file "package")
                 (:file "rfc3339")))

Fix typo in system description

Fix typo in system description


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

(defun define-ensure-generic-function-r1 (boot)
  (setf (sicl-genv:fdefinition 'ensure-generic-function (r1 boot))
	(lambda (function-name &rest arguments)
	  (let ((args (copy-list arguments)))
	    (loop while (remf args :environment))
	    (if (sicl-genv:fboundp function-name (r1 boot))
		(sicl-genv:fdefinition function-name (r1 boot))
		(setf (sicl-genv:fdefinition function-name (r1 boot))
		      (apply #'make-instance 'standard-generic-function
			     :name function-name
			     args)))))))

(defun customize-r1 (boot)
  (let ((c (c1 boot))
	(r (r1 boot)))
    (message "Customizing run-time environment R1~%")
    (define-ensure-generic-function-r1 boot)
    (message "Finished customizing run-time environment R1~%")))

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

;;; We define a special version of ENSURE-GENERIC-FUNCTION in the
;;; run-time environment R1.  While the function is defined in the
;;; run-time environment R1, it operates on the run-time environment
;;; R2.  This version checks whether there is already a function named
;;; FUNCTION-NAME in R2.  If so that function is returned, and it is
;;; assumed to be a generic function.  If not, an instance of the host
;;; class STANDARD-GENERIC-FUNCTION is created and associated with
;;; FUNCTION-NAME in R2.
(defun define-ensure-generic-function-r1 (boot)
  (setf (sicl-genv:fdefinition 'ensure-generic-function (r1 boot))
	(lambda (function-name &rest arguments)
	  (let ((args (copy-list arguments)))
	    (loop while (remf args :environment))
	    (if (sicl-genv:fboundp function-name (r2 boot))
		(sicl-genv:fdefinition function-name (r2 boot))
		(setf (sicl-genv:fdefinition function-name (r2 boot))
		      (apply #'make-instance 'standard-generic-function
			     :name function-name
			     args)))))))

(defun customize-r1 (boot)
  (let ((c (c1 boot))
	(r (r1 boot)))
    (message "Customizing run-time environment R1~%")
    (define-ensure-generic-function-r1 boot)
    (message "Finished customizing run-time environment R1~%")))

Define function in R1, but operate on R2.


;;;; bit-smasher.asd

;;;; Copyright (c) 2014--2015, "the Phoeron" Colin J.E. Lupton <//thephoeron.com>
;;;; See LICENSE for additional information.

(in-package :cl-user)

(defpackage bit-smasher-asd
  (:use :cl :asdf)
  (:export #:*bit-smasher-version*))

(in-package :bit-smasher-asd)

(defparameter *bit-smasher-version* "1.0.2")

(defsystem #:bit-smasher
  :serial t
  :description "Utility library for handling bit vectors, bit vector arithmetic, and universal integer type conversions between bit-vectors, byte-vectors, octals, decimals, and hexadecimal notation."
  :version #.*bit-smasher-version*
  :author "\"the Phoeron\" Colin J.E. Lupton <sysop@thephoeron.com>"
  :license "MIT"
  :pathname "src/"
  :depends-on (:cl-base58
               :cl-base64
               :ironclad)
  :components ((:file "packages")
               (:file "core")
               (:file "from-ironclad")
               (:file "conversion")
               (:file "arithmetic")
               (:file "aliases")
               (:file "utils"))
  :in-order-to ((test-op (test-op :bit-smasher-test))))

;;;; bit-smasher.asd

;;;; Copyright (c) 2014--2015, "the Phoeron" Colin J.E. Lupton <//thephoeron.com>
;;;; See LICENSE for additional information.

(in-package :cl-user)

(defpackage bit-smasher-asd
  (:use :cl :asdf)
  (:export #:*bit-smasher-version*))

(in-package :bit-smasher-asd)

(defparameter *bit-smasher-version* "1.0.2")

(defsystem #:bit-smasher
  :serial t
  :description "Utility library for handling bit vectors, bit vector arithmetic, and universal integer type conversions between bit-vectors, byte-vectors, octals, decimals, and hexadecimal notation."
  :version #.*bit-smasher-version*
  :author "\"the Phoeron\" Colin J.E. Lupton <sysop@thephoeron.com>"
  :license "MIT"
  :pathname "src/"
  :depends-on (:cl-base58
               :cl-base64)
  :components ((:file "packages")
               (:file "core")
               (:file "from-ironclad")
               (:file "conversion")
               (:file "arithmetic")
               (:file "aliases")
               (:file "utils"))
  :in-order-to ((test-op (test-op :bit-smasher-test))))

Remove Ironclad from system def

Remove Ironclad from system def


(cl:in-package #:cleavir-type-inference)

(defgeneric transfer (instruction input-bag))

(defmethod transfer (instruction input-bag)
  (loop with result = input-bag
	for output in (cleavir-ir:outputs instruction)
	when (typep output 'cleavir-ir:lexical-location)
	  do (setf result (update output t result))
	finally (return result)))

(cl:in-package #:cleavir-type-inference)

(defgeneric one-successor-transfer (instruction input-bag))

(defmethod one-successor-transfer (instruction input-bag)
  (loop with result = input-bag
	for output in (cleavir-ir:outputs instruction)
	when (typep output 'cleavir-ir:lexical-location)
	  do (setf result (update output t result))
	finally (return result)))

Rename in preparation for a TWO-SUCCESSORS-TRANSFER function.


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

(defun function-arguments (fun)
  (awhen fun.__source
    !.))

(defun function-body (fun)
  (awhen fun.__source
    .!))

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

(defun function-arguments (fun)
  (? fun
     (aif fun.__source
          !.
          '(&rest unknown-args))
     '(&rest unknown-args)))

(defun function-body (fun)
  (awhen fun.__source
    .!))

Allow calls to unknown functions.

Allow calls to unknown functions.


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

(defgeneric delete (leaf))

(defgeneric delete-child (parent child))

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

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

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

Define method on DELETE-CHILD specialized to TREE.