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

(defpackage :coleslaw-gh-pages
  (:use :cl)
  (:import-from :puri #:parse-uri #:uri-host)
  (:import-from :coleslaw #:*config*
                          #:deploy
                          #:deploy-dir
                          #:domain
                          #:rel-path)
  (:export #:enable))

(in-package :coleslaw-gh-pages)

(defvar *cname* nil
  "The domain CNAME for github to serve pages from.")

(defmethod deploy :after (staging)
  (let ((blog (truename (rel-path (deploy-dir *config*) ".curr"))))
    (delete-file (rel-path blog "index.html"))
    (cl-fad:copy-file (rel-path blog "1.html") (rel-path blog "index.html"))
    (with-open-file (out (rel-path blog "CNAME")
                     :direction :output
                     :if-exists :supersede
                     :if-does-not-exist :create)
      (format out "~A~%" *cname*))))

(defun enable (&key cname)
  (typecase cname
    (string (setf *cname* cname))
    (t (setf *cname* (uri-host (parse-uri (domain *config*)))))
    (otherwise (error "Not a valid CNAME: ~A" cname))))

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

(defpackage :coleslaw-gh-pages
  (:use :cl)
  (:import-from :puri #:parse-uri #:uri-host)
  (:import-from :coleslaw #:*config*
                          #:deploy
                          #:deploy-dir
                          #:domain
                          #:rel-path)
  (:export #:enable))

(in-package :coleslaw-gh-pages)

(defvar *cname* nil
  "The domain CNAME for github to serve pages from.")

(defmethod deploy :after (staging)
  (let ((blog (rel-path (deploy-dir *config*) ".curr")))
    (delete-file (rel-path blog "index.html"))
    (cl-fad:copy-file (rel-path blog "1.html") (rel-path blog "index.html"))
    (with-open-file (out (rel-path blog "CNAME")
                     :direction :output
                     :if-exists :supersede
                     :if-does-not-exist :create)
      (format out "~A~%" *cname*))))

(defun enable (&key cname)
  (typecase cname
    (string (setf *cname* cname))
    (t (setf *cname* (uri-host (parse-uri (domain *config*)))))
    (otherwise (error "Not a valid CNAME: ~A" cname))))

Remove call to truename to fix CNAME generation.


;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8;  -*-
;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
;;; See LICENSE for details.

(asdf:defsystem #:test-grid-reporting
  :version "0.1.0"
  :serial t
  :depends-on (#:test-grid-data #:test-grid-utils #:test-grid-agent #:html-template)
  :components
  ((:module "reporting"
    :serial t
    :components
    ((:file "package")
     (:file "my-time")
     (:file "cl-ex")
     (:file "do-results")
     (:file "distinct")
     (:file "html-printers")
     (:file "list-failures")
     (:file "list-results")
     (:file "templating")
     (:file "reporting")
     (:file "test-runs")
     (:file "csv")
     (:file "pivot")
     (:file "pivot2")
     (:file "quicklisp-diff")
     (:file "library-report")
     (:file "regressions")
     (:file "meta-info-from-quicklisp")
     (:file "dependencies-and-blockers")
     (:file "load-failures")
     (:file "compiler-diff")
     (:file "demo-reports")
     (:file "durations")
     (:file "contributors")))))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8;  -*-
;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
;;; See LICENSE for details.

(asdf:defsystem #:test-grid-reporting
  :version "0.1.0"
  :serial t
  :depends-on (#:test-grid-data #:test-grid-utils #:test-grid-agent #:html-template)
  :components
  ((:module "reporting"
    :serial t
    :components
    ((:file "package")
     (:file "my-time")
     (:file "cl-ex")
     (:file "do-results")
     (:file "distinct")
     (:file "html-printers")
     (:file "list-results")
     (:file "templating")
     (:file "reporting")
     (:file "test-runs")
     (:file "csv")
     (:file "pivot")
     (:file "pivot2")
     (:file "quicklisp-diff")
     (:file "library-report")
     (:file "regressions")
     (:file "meta-info-from-quicklisp")
     (:file "dependencies-and-blockers")
     (:file "load-failures")
     (:file "compiler-diff")
     (:file "demo-reports")
     (:file "durations")
     (:file "contributors")))))

Remove old unused function test-gird-reporting::list-failures


;; math-system-utils.lisp - misc. utility forms

(in-package #:math)

(define-condition entity-condition ()
  ((name
    :initarg :name
    :reader entity-condition-name)))

(define-condition entity-not-found (error entity-condition)
  ())

(define-condition redefinition-condition (style-warning)
  ((previous-object
    :initarg :previous
    :accessor redefinition-condition-previous-object)
   (new-object
    :initarg :new
    :accessor redefinition-condition-new-object)))

(define-condition container-condition ()
  ((container
    :intarg :container
    :reader container-condition-container)))

;; math-system-utils.lisp - misc. utility forms

(in-package #:math)

(define-condition entity-condition ()
  ((name
    :initarg :name
    :reader entity-condition-name)))

(define-condition entity-not-found (error entity-condition)
  ())

(define-condition redefinition-condition (style-warning)
  ((previous-object
    :initarg :previous
    :accessor redefinition-condition-previous-object)
   (new-object
    :initarg :new
    :accessor redefinition-condition-new-object)))

(define-condition container-condition ()
  ((container
    :initarg :container
    :reader container-condition-container)))

Correct typo in class defn

CONTAINER-CONDITION: Correct typo in class defn


;; Declaration of package
;; Liam Healy 2009-02-22 09:55:45EST pkgdcl.lisp
;; Time-stamp: <2009-05-12 15:27:21EDT init.lisp>

(in-package :common-lisp-user)

(defpackage :foreign-structures-by-value
  (:nicknames #:fsbv)
  (:use #:common-lisp))

(cffi:load-foreign-library
 #+darwin "libffi.dylib"
 #+(and (not darwin) unix) "libffi.so")

(pushnew :fsbv *features*)

;; Declaration of package
;; Liam Healy 2009-02-22 09:55:45EST pkgdcl.lisp
;; Time-stamp: <2009-08-22 16:20:00EDT init.lisp>

(in-package :common-lisp-user)

(defpackage :foreign-structures-by-value
  (:nicknames #:fsbv)
  (:use #:common-lisp))

(cffi:load-foreign-library
 #+darwin "libffi.dylib"
 #+(and (not darwin) unix) "libffi.so")

;;; When installed through Mac Ports, GSL .h files will be found
;;; in /opt/local/include.
#+darwin
(setf cffi-grovel::*cc-flags*
      (append '("-I" "/opt/local/include/") cffi-grovel::*cc-flags*))

(pushnew :fsbv *features*)

Add include path for OSX

Add include path for OSX

Darwin ports installs .h files under /opt/local/include/, so put -I
option onto cffi-grovel::*cc-flags*.


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

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

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

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

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

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

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

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

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


(defpackage #:eos-api
  (:use :cl #:api-dsl)
  (:export #:run-test-suites
           #:failed-tests))

(in-package #:eos-api)

(proclfun run-test-suites (&rest (test-suite-spec symbol)) t
  "Runs one or more Eos test suites specified by arguments and returns
an opaque result object combining all the results. The result object may
be passed to the FAILED-TESTS function to retreive the list of tests
failed in all the test sutes.")

(proclfun failed-tests ((test-suite-result t)) list
  "List of failed test names. Test names are downcased strings.
The TEST-SUITE-RESULT parameter must be a result of the RUN-TEST-SUITE
function.")

(defpackage #:eos-api
  (:use :cl #:api-dsl)
  (:export #:run-test-suites
           #:failed-tests))

(in-package #:eos-api)

(proclfun run-test-suites (&rest (test-suite-spec symbol)) t
  "Runs one or more Eos test suites specified by arguments and returns
an opaque result object combining all the results. The result object may
be passed to the FAILED-TESTS function to retreive the list of tests
failed in all the test sutes.")

(proclfun failed-tests ((test-suite-result t)) list
  "List of failed test names. Test names are downcased strings.
The TEST-SUITE-RESULT parameter must be a result of the RUN-TEST-SUITES
function.")

Fix typo in a docstring.

Fix typo in a docstring.


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

(defgeneric iterative-traversal (tree pre in post))

(defmethod iterative-traversal ((tree node-with-parent) pre in post)
  (let ((current-node tree))
    (tagbody
     pre
       (if (funcall pre current-node)
	   (let ((left (left current-node)))
	     (if (null left)
		 (go in)
		 (progn (setf current-node left)
			(go pre))))
	   (go in))
     in
       (if (funcall in current-node)
	   (let ((right (right current-node)))
	     (if (null right)
		 (go post)
		 (progn (setf current-node right)
			(go pre))))
	   (go post))
     post
       (funcall post current-node)
       (let ((parent (parent current-node)))
	 (if (null parent)
	     (return-from iterative-traversal)
	     (if (eq current-node (left parent))
		 (progn (setf current-node parent)
			(go in))
		 (progn (setf current-node parent)
			(go post))))))))

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

;;;; Depth-first iterative traversal.
;;;;
;;;; PRE, IN, and POST are functions of a single variable.  Each of
;;;; these functions is called with a NODE as its argument.
;;;;
;;;; Before a node is visited, PRE is called with that node as an
;;;; argument.  If PRE returns true, this is an indication that the
;;;; left sub-tree of that node should be visited.  Otherwise, the
;;;; current node is treated as if its left sub-tree were NIL.
;;;;
;;;; After the left sub-tree of some node has been visited, IN is
;;;; called with that node as an argument.  If IN returns true, this
;;;; is an indication that the right sub-tree of that node should be
;;;; visited.  Otherwise, the current node is treated as if its right
;;;; sub-tree were NIL.
;;;;
;;;; After the right sub-tree of some node has been visited, POST is
;;;; called with that node as an argument.  The return value of POST
;;;; is ignored.

(defgeneric iterative-traversal (tree pre in post))

(defmethod iterative-traversal ((tree node-with-parent) pre in post)
  (let ((current-node tree))
    (tagbody
     pre
       (if (funcall pre current-node)
	   (let ((left (left current-node)))
	     (if (null left)
		 (go in)
		 (progn (setf current-node left)
			(go pre))))
	   (go in))
     in
       (if (funcall in current-node)
	   (let ((right (right current-node)))
	     (if (null right)
		 (go post)
		 (progn (setf current-node right)
			(go pre))))
	   (go post))
     post
       (funcall post current-node)
       (let ((parent (parent current-node)))
	 (if (null parent)
	     (return-from iterative-traversal)
	     (if (eq current-node (left parent))
		 (progn (setf current-node parent)
			(go in))
		 (progn (setf current-node parent)
			(go post))))))))

Add comment explaining what ITERATIVE-TRAVERSAL does.


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

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

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

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

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

Add English documentation for function (SETF RIGHT).


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

(defmacro when (predicate &rest expr)
  `(and ,predicate
        ,(if (cdr expr)
	         `(progn ,@expr)
	         (car expr))))

(defmacro unless (predicate &rest expr)
  `(when (not ,predicate) ,@expr))

(defun group2 (x)
  (if x
      (cons (if (cdr x)
	  		    (list (car x) (cadr x))
	  		    (list (car x)))
	        (group2 (cddr x)))))

(defmacro case (val &rest cases)
  (let g (gensym)
    `(let ,g ,val
       (if
         ,@(apply #'append (%simple-mapcar
						      #'((x)
              				      (if (cdr x)
                   				      `((equal ,g ,(car x)) ,(cadr x))
	   	          				      (list (car x))))
       				       (group2 cases)))))))

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

(defmacro when (predicate &rest expr)
  `(and ,predicate
        ,(if (cdr expr)
	         `(progn ,@expr)
	         (car expr))))

(defmacro unless (predicate &rest expr)
  `(when (not ,predicate) ,@expr))

(defun group2 (x)
  (if x
      (cons (if (cdr x)
	  		    (list (car x) (cadr x))
	  		    (list (car x)))
	        (group2 (cddr x)))))

(defmacro case (&rest cases)
  (let g (gensym)
    (let op (if (eq :test (car cases))
                (cadr cases)
                'equal)
      (let v (if (eq :test (car cases))
                 (caddr cases)
                 (car cases))
        `(let ,g ,v
           (if
             ,@(apply #'append (%simple-mapcar
						          #'((x)
              				          (if (cdr x)
                   				          `((,op ,g ,(car x)) ,(cadr x))
	   	          				          (list (car x))))
       				           (group2 (if (eq :test (car cases))
                                           (cdddr cases)
                                           (cdr cases)))))))))))

CASE: TEST keyword accepted as first argument.


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

(asdf:defsystem :cleavir-hir
  :depends-on (:cleavir-ir)
  :serial t
  :components
  ((:file "data")
   (:file "box-unbox-mixins")
   (:file "side-effect-mixins")
   (:file "general-purpose-instructions")
   (:file "fixnum-related-instructions")
   (:file "integer-related-instructions")
   (:file "float-related-instructions")
   (:file "cons-related-instructions")
   (:file "standard-object-related-instructions")
   (:file "array-related-instructions")
   (:file "multiple-value-related-instructions")
   (:file "environment-related-instructions")
   (:file "graphviz-drawing")))

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

(defsystem :cleavir-hir
  :depends-on (:cleavir-ir)
  :serial t
  :components
  ((:file "data")
   (:file "box-unbox-mixins")
   (:file "side-effect-mixins")
   (:file "general-purpose-instructions")
   (:file "fixnum-related-instructions")
   (:file "integer-related-instructions")
   (:file "float-related-instructions")
   (:file "cons-related-instructions")
   (:file "standard-object-related-instructions")
   (:file "array-related-instructions")
   (:file "multiple-value-related-instructions")
   (:file "environment-related-instructions")
   (:file "graphviz-drawing")))

Use package ASDF-USER to define system.

Use package ASDF-USER to define system.


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

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

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

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

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

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

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

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

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

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

(defparameter *x86-64* (make-instance 'cleavir-processor-x86-64:x86-64))

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

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

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

Use Cleavir def of x86-64.

Use Cleavir def of x86-64.


;; Common Lisp version
;; Manoel Vilela

(defun div (x d)
  (= (mod x d) 0))

(defun special-sum (n)
  (reduce '+ (loop for x from 1 to n when (or (div x 5) (div x 3)) collect x)))

(format t "~d" (special-sum 1000))

;; Common Lisp version
;; Manoel Vilela

(defun div (x d)
  (= (mod x d) 0))

(defun special-sum (n)
  (reduce '+ (loop for x from 1 to n when (or (div x 5) (div x 3)) collect x)))

(format t "~d" (special-sum 999))

Fix a little error on CommonLisp solution at P001

The loop-for macro using ~from-to~ had a interval closed [a, b]
differs common range functions like Python and Clojure, whose
the range is [a, b).


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

(defsystem com.gigamonkeys.parser
  :author "Peter Seibel <peter@gigamonkeys.com>"
  :components
  ((:file "packages")
   (:file "parser" :depends-on ("packages")))
  :depends-on (:com.gigamonkeys.macro-utilities
	       :com.gigamonkeys.utilities))

;;
;; Copyright (c) 2005-2011, Peter Seibel. All rights reserved.
;;

(defsystem com.gigamonkeys.parser
  :author "Peter Seibel <peter@gigamonkeys.com>"
  :description "Parser generator, loosely based on Henry Baker's META paper."
  :components
  ((:file "packages")
   (:file "parser" :depends-on ("packages")))
  :depends-on (:com.gigamonkeys.macro-utilities
               :com.gigamonkeys.utilities))

Add description to .asd file.

Add description to .asd file.


(in-package #:sicl-data-and-control-flow)

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

(cl:in-package #:sicl-data-and-control-flow)

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

Use explicit package prefix for IN-PACKAGE.


(defpackage :coleslaw-static-pages
  (:use :cl)
  (:export #:enable)
  (:import-from :coleslaw #:*config*
                          #:content
                          #:content-text
                          #:page-url
                          #:find-all
                          #:render
                          #:publish
                          #:theme-fn
                          #:render-text
                          #:write-document))

(in-package :coleslaw-static-pages)

(defclass page (content)
  ((title :initarg :title :reader title-of)
   (url :initarg :url :reader page-url)))

(defmethod initialize-instance :after ((object page) &key)
  ;; Expect all static-pages to be written in Markdown for now.
  (with-slots (url coleslaw::text) object
    (setf url (make-pathname :defaults url)
          coleslaw::text (render-text coleslaw::text :md))))

(defmethod render ((object page) &key next prev)
  ;; For the time being, we'll re-use the normal post theme.
  (declare (ignore next prev))
  (funcall (theme-fn 'post) (list :config *config*
                                  :post object)))

(defmethod publish ((doc-type (eql (find-class 'page))))
  (dolist (page (find-all 'page))
    (write-document page)))

(defun enable ())

(defpackage :coleslaw-static-pages
  (:use :cl)
  (:export #:enable)
  (:import-from :coleslaw #:*config*
                          #:content
                          #:find-all
                          #:render
                          #:publish
                          #:theme-fn
                          #:render-text
                          #:write-document))

(in-package :coleslaw-static-pages)

(defclass page (content)
  ((title :initarg :title :reader coleslaw::title-of)))

(defmethod initialize-instance :after ((object page) &key)
  ;; Expect all static-pages to be written in Markdown for now.
  (with-slots (coleslaw::url coleslaw::text) object
    (setf coleslaw::url (make-pathname :defaults coleslaw::url)
          coleslaw::text (render-text coleslaw::text :md))))

(defmethod render ((object page) &key next prev)
  ;; For the time being, we'll re-use the normal post theme.
  (declare (ignore next prev))
  (funcall (theme-fn 'post) (list :config *config*
                                  :post object)))

(defmethod publish ((doc-type (eql (find-class 'page))))
  (dolist (page (find-all 'page))
    (write-document page)))

(defun enable ())

Fix symbols in static pages plugin some more.


(in-package :clox)

(let ((had-error nil))

  (-> had-error () boolean)
  (defun had-error ()
    had-error)

  (-> raise-error (integer string) null)
  (defun raise-error (line message)
    (report line "" message))

  (-> report (integer string string) null)
  (defun report (line location message)
    (format *error-output* "[line ~D] Error ~A: ~A~%" line location message)
    (setf had-error t)
    nil))

;; TODO: Show actual place of problem instead of line

(in-package :clox)

(let ((had-error nil))

  (-> had-error () boolean)
  (defun had-error ()
    had-error)

  (-> reset-error-flag () null)
  (defun reset-error-flag ()
    (setf had-error nil)
    nil)

  (-> raise-error (integer string) null)
  (defun raise-error (line message)
    (report line "" message))

  (-> report (integer string string) null)
  (defun report (line location message)
    (format *error-output* "[line ~D] Error ~A: ~A~%" line location message)
    (setf had-error t)
    nil))

;; TODO: Show actual place of problem instead of line

Add option to reset error flag

Add option to reset error flag


;;;; package.lisp

(defpackage #:gpxtools
  (:use #:cl)
  (:export #:read-gpx
           #:distance
           #:elevation-gain
           #:elevation-loss
           #:distance-between
           #:elevation-diff
           #:meters-to-feet
           #:meters-to-miles
           #:get-summary
           #:summarize
           #:collect-points
           #:elevation-plot
           #:find-loop
           #:simplify
           #:write-gpx
           #:gpx-file-tracks
           #:gpx-track-segments
           #:gpx-segment-points
           #:gpx-segment-point-count

           #:gpx-pt-lat
           #:gpx-pt-lon
           #:gpx-pt-ele
           #:gpx-pt-time

           #:gpx-file-from-track
           ))

;;;; package.lisp

(defpackage #:gpxtools
  (:use #:cl)
  (:export #:read-gpx
           #:distance
           #:elevation-gain
           #:elevation-loss
           #:distance-between
           #:elevation-diff
           #:meters-to-feet
           #:meters-to-miles
           #:get-summary
           #:summarize
           #:collect-points
           #:elevation-plot
           #:find-loop
           #:simplify
           #:write-gpx
           #:gpx-file-tracks
           #:gpx-track-segments
           #:gpx-segment-points
           #:gpx-segment-point-count

           #:gpx-pt-lat
           #:gpx-pt-lon
           #:gpx-pt-ele
           #:gpx-pt-time

           #:lat
           #:lon
           #:ele
           #:gpx-file-from-track
           ))

Add lat, lon, and ele exports.

Add lat, lon, and ele exports.


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

(in-package #:petalisp.test-suite)

(check-package '#:petalisp.utilities)

(define-test wsdeque-test
  (loop repeat 100 do
    (let* ((n-threads (petalisp.utilities:number-of-cpus))
           (iterations (random 50000))
           (wsdeque (petalisp.utilities:make-wsdeque))
           (threads
             (loop for index below n-threads
                   collect
                   (bordeaux-threads:make-thread
                    (lambda ()
                      (loop repeat iterations
                            with item = nil
                            when (zerop (random n-threads))
                              do (setf item (petalisp.utilities:wsdeque-steal wsdeque))
                              and when item collect it)))))
           (v1
             (loop for value below iterations
                   with item = nil
                   do (petalisp.utilities:wsdeque-push wsdeque value)
                   when (zerop (mod value n-threads))
                     do (setf item (petalisp.utilities:wsdeque-pop wsdeque))
                     and when item collect it))
           (v3
             (loop for item = (petalisp.utilities:wsdeque-pop wsdeque)
                   while item collect item))
           (v2
             (mapcan #'bordeaux-threads:join-thread threads)))
      (is (= (+ (length v1) (length v2) (length v3)) iterations))
      (loop for expected below iterations
            for value in (sort (append v1 v2 v3) #'<)
            do (is (= value expected))))))

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

(in-package #:petalisp.test-suite)

(check-package '#:petalisp.utilities)

(define-test wsdeque-test
  (loop repeat 50 do
    (let* ((n-threads (petalisp.utilities:number-of-cpus))
           (iterations (random 20000))
           (wsdeque (petalisp.utilities:make-wsdeque))
           (threads
             (loop for index below n-threads
                   collect
                   (bordeaux-threads:make-thread
                    (lambda ()
                      (loop repeat iterations
                            with item = nil
                            when (zerop (random n-threads))
                              do (setf item (petalisp.utilities:wsdeque-steal wsdeque))
                              and when item collect it)))))
           (v1
             (loop for value below iterations
                   with item = nil
                   do (petalisp.utilities:wsdeque-push wsdeque value)
                   when (zerop (mod value n-threads))
                     do (setf item (petalisp.utilities:wsdeque-pop wsdeque))
                     and when item collect it))
           (v3
             (loop for item = (petalisp.utilities:wsdeque-pop wsdeque)
                   while item collect item))
           (v2
             (mapcan #'bordeaux-threads:join-thread threads)))
      (is (= (+ (length v1) (length v2) (length v3)) iterations))
      (loop for expected below iterations
            for value in (sort (append v1 v2 v3) #'<)
            do (is (= value expected))))))

Make the wsdeque test less expensive.

Make the wsdeque test less expensive.


(%defmacro defvar (name &optional (init '%%%no-init))
  (print-definition `(var ,name))
  (? (not (symbol? name))
     (%error "Symbol expected as variable name."))
  `(%defvar ,name ,(? (eq '%%%no-init init)
                      `',init
                      init)))

(%defmacro var (name &optional (init nil))
  `(defvar ,name ,init))

(var *constants* nil)

(%defmacro defconstant (name &optional (init nil))
  (print-definition `(defconstant ,name))
  `(progn
     (var ,name ,init)
     (setq *constants* (. (. ',name ',init) *constants*))))

(%defmacro const (name &optional (init nil))
  `(var ,name ,init))

(%defmacro defvar (name &optional (init '%%%no-init))
  (print-definition `(var ,name))
  (? (not (symbol? name))
     (%error "Symbol expected as variable name."))
  `(%defvar ,name ,(? (eq '%%%no-init init)
                      `',init
                      init)))

(%defmacro var (name &optional (init nil))
  `(defvar ,name ,init))

(var *constants* nil)

(%defmacro defconstant (name &optional (init nil))
  (print-definition `(defconstant ,name))
  `(progn
     (var ,name ,init)
     (setq *constants* (. (. ',name ',init) *constants*))))

(%defmacro const (name &optional (init nil))
  `(defconstant ,name ,init))

Convert CONST to DEFCONSTANT, not to DEFVAR.


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

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

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

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

Include component conditions.lisp in system definition.


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

(defun find-load-time-value-asts (ast)
  (if (typep ast 'cleavir-ast:load-time-value-ast)
      (list ast)
      (let ((children (cleavir-ast:children ast)))
	(reduce #'append (mapcar #'find-load-time-value-asts children)
		:from-end t))))

(defun hoist-load-time-value (ast)
  (let* ((load-time-value-asts (find-load-time-value-asts ast))
	 (forms (mapcar #'cleavir-ast:form load-time-value-asts)))
    (loop for ast in load-time-value-asts
	  do (change-class ast 'cleavir-ast:lexical-ast :name (gensym)))
    (cleavir-ast:make-top-level-function-ast
     ast load-time-value-asts forms)))

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

(defun find-load-time-value-asts (ast)
  (let ((table (make-hash-table :test #'eq)))
    (labels ((traverse (ast)
	       (unless (gethash ast table)
		 (setf (gethash ast table) t)
		 (if (typep ast 'cleavir-ast:load-time-value-ast)
		     (list ast)
		     (let ((children (cleavir-ast:children ast)))
		       (reduce #'append
			       (mapcar #'traverse children)
			       :from-end t))))))
      (traverse ast))))

(defun hoist-load-time-value (ast)
  (let* ((load-time-value-asts (find-load-time-value-asts ast))
	 (forms (mapcar #'cleavir-ast:form load-time-value-asts)))
    (loop for ast in load-time-value-asts
	  do (change-class ast 'cleavir-ast:lexical-ast :name (gensym)))
    (cleavir-ast:make-top-level-function-ast
     ast load-time-value-asts forms)))

Make sure the computation terminates even though the AST has cycles.


;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: WOLFCOIN; Base: 10 -*- file: wolfcoin.asd

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

(in-package :cl-user)

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

(in-package :wolfcoin-asd)

(defparameter *wolfcoin-version* "0.0.1")

(defsystem wolfcoin
    :version #.*wolfcoin-version*
    :author "\"the Phoeron\" Colin J.E. Lupton <sysop@thephoeron.com>"
    :license "MIT"
    :description "Crypto-currency client, protocol, and wallet written in Common Lisp."
    :serial t
    :depends-on (:local-time
                 :ironclad
                 :cl-isaac
                 :cl-json
                 :babel
                 :cl-store)
    :components ((:file "packages")
                 (:file "coin")
                 (:file "transaction")
                 (:file "p2p")
                 (:file "blockchain")
                 (:module "wallet"
                  :serial t
                  :components ((:file "db")
                               (:file "wallet")))
                 (:module "rpc"
                  :serial t
                  :components ((:file "interface")
                               (:file "rpc")))
                 (:module "client"
                  :serial t
                  :components ((:file "client")))
                 (:file "wolfcoin")))

;; EOF

;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: WOLFCOIN; Base: 10 -*- file: wolfcoin.asd

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

(in-package :cl-user)

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

(in-package :wolfcoin-asd)

(defparameter *wolfcoin-version* "0.0.1")

(defsystem wolfcoin
    :version #.*wolfcoin-version*
    :author "\"the Phoeron\" Colin J.E. Lupton <sysop@thephoeron.com>"
    :license "MIT"
    :description "Crypto-currency client, protocol, and wallet written in Common Lisp."
    :serial t
    :depends-on (:local-time
                 :ironclad
                 :cl-isaac
                 :cl-json
                 :babel
                 :cl-store
                 :ltk)
    :components ((:file "packages")
                 (:file "coin")
                 (:file "transaction")
                 (:file "p2p")
                 (:file "blockchain")
                 (:module "wallet"
                  :serial t
                  :components ((:file "db")
                               (:file "wallet")))
                 (:module "rpc"
                  :serial t
                  :components ((:file "interface")
                               (:file "rpc")))
                 (:module "client"
                  :serial t
                  :components ((:file "client")))
                 (:file "wolfcoin")))

;; EOF

Add LTK as system dependency

Add LTK as system dependency


(in-package :lispkit)

(defun load-ui-from-file (path)
  (if (probe-file path)
      (let ((builder (gtk:gtk-builder-new)))
        (gtk:gtk-builder-add-from-file builder (namestring path))
        builder)
      (error (format nil "non existent path: ~s" path))))

(defun main (&rest args)
  (declare (ignore args))
  (within-main-loop
    (let* ((ui     (load-ui-from-file
                    (asdf:system-relative-pathname :lispkit "main.ui")))
           (window (gtk:gtk-builder-get-object ui "mainwindow"))
           (frame  (gtk:gtk-builder-get-object ui "scrolledwindow"))
           (entry  (gtk:gtk-builder-get-object ui "entry_box"))
           (view   (webkit.foreign:webkit-web-view-new))
           (browser (new-browser ui view)))
      (gtk-container-add frame view)
      (g-signal-connect window "key_press_event"
                        (new-key-dispatcher browser))
      (load-url "http://www.github.com/AeroNotix/lispkit" browser)
      (gtk-widget-hide entry)
      (dolist (widget (list window frame view))
        (gtk-widget-show widget)))))

(in-package :lispkit)

(defparameter *default-page*
  "http://www.github.com/AeroNotix/lispkit")

(defun load-ui-from-file (path)
  (if (probe-file path)
      (let ((builder (gtk:gtk-builder-new)))
        (gtk:gtk-builder-add-from-file builder (namestring path))
        builder)
      (error (format nil "non existent path: ~s" path))))

(defun main (&rest args)
  (declare (ignore args))
  (within-main-loop
    (let* ((ui     (load-ui-from-file
                    (asdf:system-relative-pathname :lispkit "main.ui")))
           (window (gtk:gtk-builder-get-object ui "mainwindow"))
           (frame  (gtk:gtk-builder-get-object ui "scrolledwindow"))
           (entry  (gtk:gtk-builder-get-object ui "entry_box"))
           (view   (webkit.foreign:webkit-web-view-new))
           (browser (new-browser ui view)))
      (gtk-container-add frame view)
      (g-signal-connect window "key_press_event"
                        (new-key-dispatcher browser))
      (load-url *default-page* browser)
      (gtk-widget-hide entry)
      (dolist (widget (list window frame view))
        (gtk-widget-show widget)))))

Put the first URL into a named parameter


(%defvar *development?*       nil)
(%defvar *assert?*            t)
(%defvar *print-definitions?* t)

;; Optional environment sections.

(%defvar *tre-has-math*  t) ; Mathematical functions.
(%defvar *tre-has-class* t) ; STRUCT CLASS.

;; Transpiler

;;; Targets to include in environment:
;;; :cl     Common Lisp (sbcl)
;;; :js     JavaScript/ECMAScript (browser + node.js)
;;; :php    PHP
(%defvar *targets*                 '(:cl :js :php))

(%defvar *print-notes?*            t)
(%defvar *print-status?*           t)
(%defvar *have-environment-tests*  nil)
(%defvar *have-compiler?*          nil)

(%defvar *development?*       t)
(%defvar *assert?*            t)
(%defvar *print-definitions?* t)

;; Optional environment sections.

(%defvar *tre-has-math*  t) ; Mathematical functions.
(%defvar *tre-has-class* t) ; STRUCT CLASS.

;; Transpiler

;;; Targets to include in environment:
;;; :cl     Common Lisp (sbcl)
;;; :js     JavaScript/ECMAScript (browser + node.js)
;;; :php    PHP
(%defvar *targets*                 '(:cl :js :php))

(%defvar *print-notes?*            t)
(%defvar *print-status?*           t)
(%defvar *have-environment-tests*  nil)
(%defvar *have-compiler?*          nil)

Switch development mode back on.

Switch development mode back on.


(defmacro define-get-alias (alias real &key (class nil))
  `(defmethod ,class ,($ 'get- alias) ()
      ,real))

(defmacro define-set-alias (alias real &key (class nil))
  `(defmethod ,class ,($ 'set- alias) ()
      (= ,real x)))

(defmacro define-getset-alias (alias real &key (class nil))
  `{(define-get-alias ,alias ,real :class ,class)
    (define-set-alias ,alias ,real :class ,class)})

(defmacro define-get-alias (alias real &key (class nil))
  `(defmethod ,class ,($ 'get- alias) ()
      ,real))

(defmacro define-set-alias (alias real &key (class nil))
  `(defmethod ,class ,($ 'set- alias) (x)
      (= ,real x)))

(defmacro define-getset-alias (alias real &key (class nil))
  `{(define-get-alias ,alias ,real :class ,class)
    (define-set-alias ,alias ,real :class ,class)})

Add missing argument for setter.

Add missing argument for setter.


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

(declare-cps-exception string %string? string? string== string-concat string-upcase string-downcase string-subseq)
(dont-obfuscate push join char-code-at to-string to-upper-case to-lower-case substr length)

(js-type-predicate %string? "string")

(defun string? (x)
  (| (%string? x)
     (instanceof x (%%native "String"))))

(defun string-concat (&rest x)
  (alet (make-array)
    (dolist (i x (!.join ""))
      (& i (!.push i)))))

(defun %elt-string (seq idx)
  (& (%%%< idx seq.length)
     (code-char (seq.char-code-at idx))))

(defun string== (x y)
  (%%%== x y))

(defun string-upcase (x)
  (& x (x.to-upper-case)))

(defun string-downcase (x)
  (& x (x.to-lower-case)))

(defun string-subseq (seq start &optional (end 99999))
  (unless (< (%%%- (length seq) 1) start end)
    (? (integer== start end)
	   ""
       (seq.substr start (- end start)))))

(defun number-string (x)
  (format nil "~A" x))

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

(declare-cps-exception string %string? string? string== string-concat string-upcase string-downcase string-subseq)
(dont-obfuscate push join char-code-at to-string to-upper-case to-lower-case substr length)

(js-type-predicate %string? "string")

(defun string? (x)
  (| (%string? x)
     (instanceof x (%%native "String"))))

(defun string-concat (&rest x)
  (alet (make-array)
    (dolist (i x (!.join ""))
      (& i (!.push i)))))

(defun %elt-string (seq idx)
  (& (%%%< idx seq.length)
     (code-char (seq.char-code-at idx))))

(defun string== (x y)
  (%%%== x y))

(defun string-upcase (x)
  (& x (x.to-upper-case)))

(defun string-downcase (x)
  (& x (x.to-lower-case)))

(defun string-subseq (seq start &optional (end 99999))
  (unless (< (%%%- (length seq) 1) start end)
    (? (integer== start end)
	   ""
       (seq.substr start (- end start)))))

(defun number-string (x)
  (*String x))

Use native String instead of FORMAT.

NUMBER-STRING: Use native String instead of FORMAT.


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

(defclass node (clump-binary-tree:node)
  ((%parent :initarg :parent :initform nil :accessor parent)))

(defgeneric splay-step (node))

(defgeneric splay (node))

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

(defgeneric splay-step (node))

(defgeneric splay (node))

Remove class definition. Now, Binary-tree contains definition of node with parent.


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

(in-package :cl-user)

(prove:plan nil)

(prove:subtest "Simple HTTP/HTTPS downloads"
  (let ((uris '("https://abcl.org"
                "http://slack.net"
                "https://duckduckgo.com"
                "https://atlas.engineer")))
    (dolist (uri uris)
      (prove:ok
       (download-manager:resolve (quri:uri uri))
       (format nil "Able to download <~a>~%" uri)))))

(prove:finalize)

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

(in-package :cl-user)

(prove:plan nil)

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

(prove:finalize)

libraries/download-manager: Replace offline slack.net with Wikipedia.


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

(defun fill-environment (environment)
  (import-from-host-common-lisp environment)
  (import-from-sicl-global-environment environment)
  (import-loop-support environment)
  (define-backquote-macros environment)
  (define-defmacro environment)
  (define-in-package environment)
  (define-default-setf-expander environment)
  ;; Load a file containing a definition of the macro LAMBDA.  This
  ;; macro is particularly simple, so it doesn't really matter how it
  ;; is expanded.  This is fortunate, because that the time this file
  ;; is loaded, the definition of DEFMACRO is still one we created
  ;; "manually" and which uses the host compiler to compile the macro
  ;; function in the null lexical environment.  We define the macro
  ;; LAMBDA before we redefine DEFMACRO as a target macro because
  ;; PARSE-MACRO returns a LAMBDA form, so we need this macro in order
  ;; to redefine DEFMACRO.
  (load-file "../../Evaluation-and-compilation/lambda.lisp" environment))

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

(defun fill-environment (environment)
  (import-from-host-common-lisp environment)
  (import-from-sicl-global-environment environment)
  (import-loop-support environment)
  (define-backquote-macros environment)
  (define-defmacro environment)
  (define-in-package environment)
  (define-default-setf-expander environment)
  ;; Load a file containing a definition of the macro LAMBDA.  This
  ;; macro is particularly simple, so it doesn't really matter how it
  ;; is expanded.  This is fortunate, because that the time this file
  ;; is loaded, the definition of DEFMACRO is still one we created
  ;; "manually" and which uses the host compiler to compile the macro
  ;; function in the null lexical environment.  We define the macro
  ;; LAMBDA before we redefine DEFMACRO as a target macro because
  ;; PARSE-MACRO returns a LAMBDA form, so we need this macro in order
  ;; to redefine DEFMACRO.
  (load-file "../../Evaluation-and-compilation/lambda.lisp" environment)
  ;; Load a file containing the definition of the macro
  ;; MULTIPLE-VALUE-BIND.  We need it early because it is used in the
  ;; expansion of SETF, which we also need early for reasons explained
  ;; below.
  (load-file "../../Environment/multiple-value-bind.lisp" environment))

Load file containing definition of MULTIPLE-VALUE-BIND.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; libbrlapi - A library providing access to braille terminals for applications.
;
; Copyright (C) 2006-2018 by Mario Lang <mlang@delysid.org>
;
; libbrlapi comes with ABSOLUTELY NO WARRANTY.
;
; This is free software, placed under the terms of the
; GNU Lesser General Public License, as published by the Free Software
; Foundation; either version 2.1 of the License, or (at your option) any
; later version. Please see the file LICENSE-LGPL for details.
;
; Web Page: http://brltty.com/
;
; This software is maintained by Dave Mielke <dave@mielke.cc>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'asdf)
(require 'sb-posix)

(setf asdf:*central-registry*
  (list*
    (concatenate 'string (sb-posix:getcwd) "/")
    asdf:*central-registry*
  )
)

(asdf:operate 'asdf:load-op 'brlapi)
(require 'brlapi)

(defun brlapi-test (&optional)
  "Perform a test of various BrlAPI functiins."

  (let (
      (display (brlapi:open-connection))
    )

    (brlapi:print-object display *standard-output*)
    (brlapi:close-connection display)
  )
)

(brlapi-test)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; libbrlapi - A library providing access to braille terminals for applications.
;
; Copyright (C) 2006-2018 by Mario Lang <mlang@delysid.org>
;
; libbrlapi comes with ABSOLUTELY NO WARRANTY.
;
; This is free software, placed under the terms of the
; GNU Lesser General Public License, as published by the Free Software
; Foundation; either version 2.1 of the License, or (at your option) any
; later version. Please see the file LICENSE-LGPL for details.
;
; Web Page: http://brltty.com/
;
; This software is maintained by Dave Mielke <dave@mielke.cc>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'asdf)
(require 'sb-posix)

(pushnew
  (concatenate 'string (sb-posix:getcwd) "/")
  asdf:*central-registry*
  :test #'equal
)

(asdf:operate 'asdf:load-op 'brlapi)
(require 'brlapi)

(defun brlapi-test (&optional)
  "Perform a test of various BrlAPI functiins."

  (let (
      (display (brlapi:open-connection))
    )

    (brlapi:print-object display *standard-output*)
    (brlapi:close-connection display)
  )
)

(brlapi-test)

Improve the way that brlapi.lisp is found. (ml)


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

(defsystem gigamonkey-distcompiler
  :components
  ((:file "packages")
   (:file "tarhash" :depends-on ("packages"))
   (:file "distcompiler" :depends-on ("packages" "tarhash")))
  :depends-on (:ironclad))

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

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

Add needed dependencies to .asd.

Add needed dependencies to .asd.


(cl:in-package #:cleavir-boolean-elimination)

(defun find-boolean-tests (initial-instruction)
  (let ((result '()))
    (cleavir-ir:map-instructions-arbitrary-order
     (lambda (instruction)
       (when (typep instruction 'cleavir-ir:eq-instruction)
	 (destructuring-bind (i1 i2) (cleavir-ir:inputs instruction)
	   (when (or (boolean-input-p i1 nil)
		     (boolean-input-p i2 nil))
	     (push instruction result)))))
     initial-instruction)
    result))

(cl:in-package #:cleavir-boolean-elimination)

;;; We search for EQ-INSTRUCTIONs where one of the inputs is a
;;; LOAD-TIME-VALUE-INPUT with a constant form of NIL, meaning that
;;; the instruction tests its other input as a Boolean.  We return a
;;; list of such instructions in the program.
(defun find-boolean-tests (initial-instruction)
  (let ((result '()))
    (cleavir-ir:map-instructions-arbitrary-order
     (lambda (instruction)
       (when (typep instruction 'cleavir-ir:eq-instruction)
	 (destructuring-bind (i1 i2) (cleavir-ir:inputs instruction)
	   (when (or (boolean-input-p i1 nil)
		     (boolean-input-p i2 nil))
	     (push instruction result)))))
     initial-instruction)
    result))

Add comment explaining what the function does.


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

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Given a symbol S (no matter what package), return a singleton
;;; parser Q that recognizes symbols with the same name as S.  If Q
;;; succeeds, it returns S.

(defun keyword-parser (symbol)
  (singleton (constantly symbol)
	     (lambda (token) (symbol-equal symbol token))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser for COMPOUND-FORM+, i.e. a non-empty sequence of compound
;;; forms.

(define-parser compound+
  (repeat+ (lambda (&rest forms)
	     (cons 'progn forms))
	   (singleton #'identity #'consp)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This parser succeeds whenever the list of tokens is either empty
;;; or starts with a form that is not a loop keyword that can start a
;;; clause.  When it succeeds, it returns NIL as the result and the
;;; original list of tokens.

(defparameter *clause-keywords*
  '(#:initially #:finally
    #:with
    #:do #:return
    #:collect #:collecting
    #:append #:appending
    #:nconc #:nconcing
    #:count #:counting
    #:sum #:summing
    #:maximize #:maximizing
    #:minimize #:minimizing
    #:if #:when #:unless
    #:while #:until #:repeat #:always #:never #:thereis
    #:for #:as))

(defun non-clause-keyword (tokens)
  (if (or (null tokens)
	  (member (car tokens) *clause-keywords*
		  :test #'symbol-equal))
      (values t nil tokens)
      (values nil nil tokens)))

Add a parser that recognizes things that are not clause keywords.


(in-package :coleslaw)

(defun date-to-timestamp (date)
  "Convert a post DATE to a local-time timestamp."
  (destructuring-bind (date time) (cl-ppcre:split " " date)
    (apply 'local-time:encode-timestamp 0
           (mapcar #'parse-integer
                   (append (reverse (cl-ppcre:split ":" time))
                           (reverse (cl-ppcre:split "-" date)))))))

(defun make-pubdate (&optional date)
  "Make a RFC1123 pubdate representing the current time or DATE, when supplied."
  (let ((timestamp (if date
                       (date-to-timestamp date)
                       (local-time:now))))
    (local-time:format-rfc1123-timestring nil timestamp)))

(defun render-feeds (feeds)
  "Render and write the given FEEDS for the site."
  (flet ((first-10 (list)
           (subseq list 0 (min (length list) 10))))
    (let* ((by-date (by-date (hash-table-values *posts*)))
           (posts (first-10 by-date)))
      (render-page (make-instance 'index :path "rss.xml" :posts posts) :rss-feed)
      (render-page (make-instance 'index :path "feed.atom" :posts posts) :atom-feed)
      (dolist (feed feeds)
        (let ((index (index-by-tag feed by-date)))
          (setf (index-path index) (format nil "tag/~a-rss.xml" feed)
                (index-posts index) (first-10 (index-posts index)))
          (render-page index :rss))))))

(in-package :coleslaw)

(defun make-pubdate (&optional date)
  "Make a RFC1123 pubdate representing the current time or DATE, when supplied."
  (let ((timestamp (if date
                       (date-to-timestamp date)
                       (local-time:now))))
    (local-time:format-rfc1123-timestring nil timestamp)))

(defun render-feeds (feeds)
  "Render and write the given FEEDS for the site."
  (flet ((first-10 (list)
           (subseq list 0 (min (length list) 10))))
    (let* ((by-date (by-date (hash-table-values *posts*)))
           (posts (first-10 by-date)))
      (render-page (make-instance 'index :path "rss.xml" :posts posts) :rss-feed)
      (render-page (make-instance 'index :path "feed.atom" :posts posts) :atom-feed)
      (dolist (feed feeds)
        (let ((index (index-by-tag feed by-date)))
          (setf (index-path index) (format nil "tag/~a-rss.xml" feed)
                (index-posts index) (first-10 (index-posts index)))
          (render-page index :rss))))))

Remove DATE-TO-TIMESTAMP since it was unused.


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

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

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

Add method on PRINT-OBJECT specialized to BUILT-IN-CLASS.


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

(defvar *db* nil)

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

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

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

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

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

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

(defun save-db (filename)
  (with-open-file (out filename
		       :direction :output
		       :if-exists :supersede)
    (with-standard-io-syntax
      (print *db* out))))

Add function to save database to file

Add function to save database to file


;;;; -*- lisp -*-

(defpackage :it.bese.yaclml.test
  (:use :common-lisp
        :arnesi
        :iterate
	:it.bese.yaclml
	:it.bese.FiveAM))

(unless (5am:get-test :it.bese)
  (5am:def-suite :it.bese))

(5am:def-suite :it.bese.yaclml :in :it.bese)

;;;; -*- lisp -*-

(defpackage :it.bese.yaclml.test
  (:use :common-lisp
        :arnesi
        :iterate
	:it.bese.yaclml
	:it.bese.FiveAM))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (5am:get-test :it.bese)
    (5am:def-suite :it.bese)))

(5am:def-suite :it.bese.yaclml :in :it.bese)

Make sure the :it.bese suite is defined in time.


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

(defvar *global-environment*)

(defun expand-place (place environment)
  (when (null environment)
    (setf environment *global-environment*))
  (cond ((symbolp place)
	 (let ((expansion (cleavir-env:symbol-macro-expansion place environment)))
	   (if (eq place expansion)
	       place
	       (expand-place expansion environment))))
	((and (consp place) (symbolp (first place)))
	 (let ((expander (cleavir-env:macro-function (first place)
						     environment)))
	   (if (null expander)
	       place
	       (expand-place (funcall expander place environment) environment))))
	(t
	 (error "Invalid place ~s" place))))

(defun get-setf-expansion (place &optional environment)
  (when (null environment)
    (setf environment *global-environment*))
  (let* ((expanded-place (expand-place place environment))
	 (expander (if (symbolp expanded-place)
		       (default-setf-expander *global-environment*)
		       (or (setf-expander (first expanded-place)
					  *global-environment*)
			   (default-setf-expander *global-environment*)))))
    (funcall expander expanded-place)))

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

(defvar *global-environment*)

(defun expand-place (place environment)
  (when (null environment)
    (setf environment *global-environment*))
  (cond ((symbolp place)
	 (let ((expansion (cleavir-env:symbol-macro-expansion place environment)))
	   (if (eq place expansion)
	       place
	       (expand-place expansion environment))))
	((and (consp place) (symbolp (first place)))
	 (let ((expander (cleavir-env:macro-function (first place)
						     environment)))
	   (if (null expander)
	       place
	       (expand-place (funcall expander place environment) environment))))
	(t
	 (error "Invalid place ~s" place))))

(defun get-setf-expansion (place &optional environment)
  (when (null environment)
    (setf environment *global-environment*))
  (let* ((global-environment (cleavir-env:global-environment environment))
	 (expanded-place (expand-place place environment))
	 (expander (if (symbolp expanded-place)
		       (default-setf-expander global-environment)
		       (or (setf-expander (first expanded-place)
					  global-environment)
			   (default-setf-expander global-environment)))))
    (funcall expander expanded-place)))

Use new Cleavir function to find the global environment.


(fn html-option (value name selected)
  (string-concat "<option value=\"" value "\""
                (& (string== selected value)
                   " selected")
                ">" name "</option>"))

(fn html-options (x selected)
  (apply #'string-concat (@ [html-option _. ._ selected] x)))

(fn html-option (value name selected)
  (string-concat "<option value=\"" value "\""
                 (& (eql selected value)
                    " selected")
                 ">" name "</option>"))

(fn html-options (x selected)
  (apply #'string-concat (@ [html-option _. ._ selected] x)))

HTML-OPTION: Use EQL instead of STRING== to find selected options.


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

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

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

(defun fill-environment (environment)
  (sicl-genv:fmakunbound 'sicl-type:typep environment)
  (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))

Remove definition of TYPEP in preparation for a new one as a generic function.


(in-package :cl-user)
(defpackage cl-emoji-test
  (:use :cl
        :cl-emoji
        :prove))
(in-package :cl-emoji-test)

;; NOTE: To run this test file, execute `(asdf:test-system :cl-emoji)' in your Lisp.

(with-open-file (s (asdf:system-relative-pathname
		    :cl-emoji (pathname (format nil "data/emoji_~a.lisp"
                                        cl-emoji::*current-version*))))
  (let ((emoji-list (read s)))
    (plan (+ 6 (length emoji-list)))
    (dolist (u emoji-list)
      (is (length u) 6))
    (is "😀" (emoji:codepoint '("U+1F600")))
    (is "😁" (emoji:name "grinning face with smiling eyes"))
    (ok (< 0 (length (emoji:annotation "blue"))))
    (ok (< 0 (length (emoji:group "Smileys & People"))))
    (ok (< 0 (length (emoji:subgroup "clothing"))))
    (with-emoji-list (emoji-list)
      (is (emoji:with-emoji-list (el)
            (reduce (lambda (s e) (concatenate 'string s (getf e :characters)))
                    (subseq el 0 5) :initial-value ""))
          "😀😁😂🤣😃"))))

(finalize)

(in-package :cl-user)
(defpackage cl-emoji-test
  (:use :cl
        :cl-emoji
        :prove))
(in-package :cl-emoji-test)

;; NOTE: To run this test file, execute `(asdf:test-system :cl-emoji)' in your Lisp.

(with-open-file (s (asdf:system-relative-pathname
		    :cl-emoji (pathname (format nil "data/emoji_~a.lisp"
                                        cl-emoji::*current-version*))))
  (let ((emoji-list (read s)))
    (plan (+ 6 (length emoji-list)))
    (dolist (u emoji-list)
      (is (length u) 12))
    (is "😀" (emoji:codepoint '("U+1F600")))
    (is "😁" (emoji:name "grinning face with smiling eyes"))
    (ok (< 0 (length (emoji:annotation "blue"))))
    (ok (< 0 (length (emoji:group "Smileys & People"))))
    (ok (< 0 (length (emoji:subgroup "clothing"))))
    (with-emoji-list (emoji-list)
      (is (emoji:with-emoji-list (el)
            (reduce (lambda (s e) (concatenate 'string s (getf e :characters)))
                    (subseq el 0 5) :initial-value ""))
          "😀😁😂🤣😃"))))

(finalize)

Test follows new emoji-list format

Test follows new emoji-list format


(defpackage #:hello-world
  (:use #:cl)
  (:export #:hello))
(in-package #:hello-world)

(defun hello ())

(defpackage #:hello-world
  (:use #:cl)
  (:export #:hello))
(in-package #:hello-world)

(defun hello () "Put your greeting here.")

Add in stub string for the exercise.

Add in stub string for the exercise.

This is meant to be the VERY FIRST exercise - so extra hand-holding
required.

The benefit of this hand-holding is that now the student will have
been shown how to make literal strings - so I won't feel bad about
using literal strings without further explanation.


;;; An interface to Kpathsea (TeX's file search library)
;;; Copr. 2002 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
;;; This is free software, licensed under GNU GPL (see file COPYING)

(in-package :kpathsea)

(defun find-file (name)
  #+cmu
  (let ((process
	 (extensions:run-program "kpsewhich" (list (namestring name))
				 :output :stream)))
    (prog1
	(parse-namestring
	 (read-line (extensions:process-output process) nil nil))
      (extensions:process-close process)))
  #-cmu
  (error "FIND-FILE is not implemented"))

#|
(find-file "amsalpha.bst")
|#

;;; An interface to Kpathsea (TeX's file search library)
;;; Copr. 2002 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
;;; This is free software, licensed under GNU GPL (see file COPYING)

(in-package :kpathsea)

;; We use CLOCC PORT to run programs if we are not running in CMUCL or SBCL.
#-(or cmu sbcl)
(require "PORT")

(defun find-file (name)
  #+cmu
  (let ((process
	 (extensions:run-program "kpsewhich" (list (namestring name))
				 :output :stream)))
    (let ((line (read-line (extensions:process-output process) nil nil)))
      (prog1
	  (and line
	       (parse-namestring line))
      (extensions:process-close process))))
  #+sbcl
  (let ((process
	 (sb-ext:run-program "/usr/bin/env"
			     (list "kpsewhich" (namestring name))
			     :output :stream)))
    (let ((line (read-line (sb-ext:process-output process) nil nil)))
      (prog1
	  (and line
	       (parse-namestring line))
      (sb-ext:process-close process))))
  #-(or cmu sbcl)
  (let ((stream (port:pipe-input "kpsewhich" (namestring name))))
    (let ((line (read-line stream nil nil)))
      (prog1
	  (and line (parse-namestring line))
	(port:close-pipe stream)))))

#|
(find-file "amsalpha.bst")
|#

(find-file): Implement for SBCL; implement for all other platforms
using CLOCC PORT.


; bender – Copyright (c) 2014–2015 Sven Michael Klose <pixel@copei.de>

(load "./environment/platforms/shared/read-binary.lisp")
(load "./environment/platforms/shared/xml2lml.lisp")

(load "src/6502.lisp")
(load "src/instruction.lisp")
(load "src/print.lisp")
(load "src/disassembler.lisp")
(load "src/instruction-map.lisp")
(load "src/cycles.lisp")
(load "src/labels.lisp")
(load "src/tokenizer.lisp")
(load "src/parser.lisp")
(load "src/labels-to-exprs.lisp")
(load "src/helpers.lisp")
(load "src/assembler.lisp")
(load "src/vice.lisp")
(load "src/bin2cbmtap.lisp")
(load "src/decode-cbmtap.lisp")
(load "src/tap.lisp")
(load "src/tap2wav.lisp")
(load "src/ascii2petscii.lisp")
(load "src/tests.lisp")

(dump-system "bender")
(quit)

; bender – Copyright (c) 2014–2015 Sven Michael Klose <pixel@copei.de>

(load "./environment/platforms/shared/read-binary.lisp")
(load "./environment/platforms/shared/xml2lml.lisp")

(load "src/6502.lisp")
(load "src/instruction.lisp")
(load "src/print.lisp")
(load "src/disassembler.lisp")
(load "src/instruction-map.lisp")
(load "src/cycles.lisp")
(load "src/labels.lisp")
(load "src/tokenizer.lisp")
(load "src/parser.lisp")
(load "src/labels-to-exprs.lisp")
(load "src/helpers.lisp")
(load "src/assembler.lisp")
(load "src/vice.lisp")
(load "src/bin2cbmtap.lisp")
(load "src/decode-cbmtap.lisp")
(load "src/tap.lisp")
(load "src/tap2wav.lisp")
(load "src/ascii2petscii.lisp")
(load "src/cbm-basic.lisp")
(load "src/tests.lisp")

(dump-system "bender")
(quit)

Load the CBM basic keywords.

Load the CBM basic keywords.


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

(defclass optional-parameter ()
  (;; This slot contains the CST for the obligatory variable of the
   ;; optional parameter.
   (%variable-cst :initarg :variable-cst :reader variable-cst)
   ;; This slot contains a CST for the INIT-FORM of the optional
   ;; parameter.  If no INIT-FORM was supplied, then this slot
   ;; contains a CST for which both EXPRESSION and LOCATION return
   ;; NIL.
   (%init-form-cst :initarg :init-form-cst :reader init-form-cst)
   ;; This slot contains a CST for the SUPPLIED-P-PARAMETER of the
   ;; optional parameter.  If no SUPPLIED-P-PARAMETER was given, then
   ;; this slot contains NIL.
   (%supplied-p-parameter-cst :initform :supplied-p-parameter-cst
			      :reader supplied-p-parameter-cst)))

(defclass optional-parameters ()
  (;; This slot contains a CST for the lambda-list keyword.
   ;; Typically, this keyword will be &OPTIONAL, but client code may
   ;; define other lambda-list keywords that work the same way as
   ;; &OPTIONAL.
   (%keyword-cst :initarg :keyword-cst :reader keyword-cst)
   ;; This slot contains a list of instances of the class
   ;; OPTIONAL-PARAMETER.
   (%parameters :initarg :parameters :reader parameters)))

Define a class for representing a list of optional parameters.


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

(defmacro if (test true &optional false)
  (cond
    (false
      `(cond
         (,test ,true)
         (t ,false)))
    (t `(cond (,test ,true)))))

(%defun compiler-and (x)
  (cond
    ((cdr x)
      `(cond
        (,(car x) ,(compiler-and (cdr x)))))
    (t       (car x))))

(defmacro and (&rest x)
  (compiler-and x))

(%defun compiler-or (x)
  (cond
    ((cdr x)
      (let ((g (gensym)))
        `(let ((,g ,(car x)))
          (cond
            ((eq ,g nil) ,(compiler-or (cdr x)))
            (t ,g)))))
    (t (car x))))

(defmacro or (&rest exprs)
  (compiler-or exprs))

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

(defmacro if (test true &optional false)
  (cond
    (false
      `(cond
         (,test ,true)
         (t ,false)))
    (t `(cond (,test ,true)))))

(%defun compiler-and (x)
  (cond
    ((cdr x)
      `(cond
        (,(car x) ,(compiler-and (cdr x)))))
    (t       (car x))))

(defmacro and (&rest x)
  (compiler-and x))

(%defun compiler-or (x)
  (cond
    ((cdr x)
      (let ((g (gensym)))
        `(let ((,g ,(car x)))
          (cond
            ((not ,g) ,(compiler-or (cdr x)))
            (t ,g)))))
    (t (car x))))

(defmacro or (&rest exprs)
  (compiler-or exprs))

Use NOT instead of EQ - breaks transpiler/javascript otherwise.


(in-package :sdl2)

(defun get-window-wm-info (window)
  (c-with ((info sdl2-ffi:sdl-syswm-info))
    (setf (info :version :major) sdl2-ffi:+sdl-major-version+
          (info :version :minor) sdl2-ffi:+sdl-minor-version+
          (info :version :patch) sdl2-ffi:+sdl-patchlevel+)
    (sdl-get-window-wm-info window (info &))
    (let ((subsystem (autowrap:enum-key 'sdl2-ffi:sdl-syswm-type
                                        (info :subsystem))))
      (list*
       :subsystem subsystem
       (ecase subsystem
         (:x11
          (list :display (info :info :x11 :display)
                :window (info :info :x11 :window)))
         (:windows
          (list :window (info :info :win :window)
                :hdc (info :info :win :hdc))))))))

(in-package :sdl2)

(defun get-window-wm-info (window)
  (c-with ((info sdl2-ffi:sdl-syswm-info))
    (setf (info :version :major) sdl2-ffi:+sdl-major-version+
          (info :version :minor) sdl2-ffi:+sdl-minor-version+
          (info :version :patch) sdl2-ffi:+sdl-patchlevel+)
    (sdl-get-window-wm-info window (info &))
    (let ((subsystem (autowrap:enum-key 'sdl2-ffi:sdl-syswm-type
                                        (info :subsystem))))
      (list*
       :subsystem subsystem
       (ecase subsystem
         #+(not (or windows darwin))
         (:x11
          (list :display (info :info :x11 :display)
                :window (info :info :x11 :window)))
         #+windows
         (:windows
          (list :window (info :info :win :window)
                :hdc (info :info :win :hdc))))))))

Make sure not to build subsystem code for platforms that don't support it


;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

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

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

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

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

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

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

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

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

;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

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

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

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

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

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

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

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

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

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

darcs-hash:20060124140012-dd2a1-3d8e2da1166317bcce072289d9f721be2002a19e.gz


(in-package #:asdf-user)

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

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

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

Use explicit package prefix with IN-PACKAGE.


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

;;;; This file produces two warnings due to redefinitions of
;;;; renderer-thread-p and ffi-initialize.
;;;;
;;;; This is necessary to modify the behavior of renderer-gtk to use
;;;; gobject to launch/manage the main GTK thread. When/if this
;;;; renderer will fully utilize gobject introspection (by taking the
;;;; changes made on the respectively named branch, and reapplying
;;;; them), then these errors will disappear, as there will be no
;;;; reliance on renderer-gtk (and thus, no redefinition).

(in-package :nyxt)

(handler-bind ((warning #'muffle-warning))
  (defun renderer-thread-p ()
    (string= "main thread" (bt:thread-name (bt:current-thread))))
  (defmethod ffi-initialize ((browser gtk-browser) urls startup-timestamp)
    (log:debug "Initializing Gobject-GTK Interface")
    (setf gtk-running-p t)
    (let ((main-thread (bt:make-thread
                        (lambda ()
                          (with-protect ("Error on GTK thread: ~a" :condition)
                            (glib:g-set-prgname "nyxt")
                            (gdk:gdk-set-program-class "Nyxt")
                            (gir:invoke ((gir:ffi "Gtk") 'main))))
                        :name "main thread")))
      (finalize browser urls startup-timestamp)
      (unless *run-from-repl-p*
        (bt:join-thread main-thread)))))

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

;;;; This file produces two warnings due to redefinitions of
;;;; renderer-thread-p and ffi-initialize.
;;;;
;;;; This is necessary to modify the behavior of renderer-gtk to use
;;;; gobject to launch/manage the main GTK thread. When/if this
;;;; renderer will fully utilize gobject introspection (by taking the
;;;; changes made on the respectively named branch, and reapplying
;;;; them), then these errors will disappear, as there will be no
;;;; reliance on renderer-gtk (and thus, no redefinition).

(in-package :nyxt)

(handler-bind ((warning #'muffle-warning))
  (defun renderer-thread-p ()
    (string= "main thread" (bt:thread-name (bt:current-thread))))
  (defmethod ffi-initialize ((browser gtk-browser) urls startup-timestamp)
    (log:debug "Initializing GObject-GTK Interface")
    (setf gtk-running-p t)
    (let ((main-thread (bt:make-thread
                        (lambda ()
                          (with-protect ("Error on GTK thread: ~a" :condition)
                            (glib:g-set-prgname "nyxt")
                            (gdk:gdk-set-program-class "Nyxt")
                            (gir:invoke ((gir:ffi "Gtk") 'main))))
                        :name "main thread")))
      (finalize browser urls startup-timestamp)
      (unless *run-from-repl-p*
        (bt:join-thread main-thread)))))

Fix case in debug message.

GObject-GTK: Fix case in debug message.


;;;; 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 standard-direct-slot-definition
    (standard-slot-definition direct-slot-definition)
  ())

Add copyright dates and license statement.


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

(defun ast-from-stream (stream environment system)
  (let ((*compiler* 'compile-file))
    (cleavir-ast:make-progn-ast
     (let ((eof (list nil)))
       (loop for form = (read stream nil eof)
	     until (eq form eof)
	     collect (generate-ast form environment system))))))

(defun ast-from-file (filename environment system)
  (with-open-file (stream filename :direction :input)
    (ast-from-stream stream environment system)))

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

(defun ast-from-stream (stream environment system)
  (let ((*compiler* 'compile-file))
    (process-progn
     (let ((eof (list nil)))
       (loop for form = (read stream nil eof)
	     until (eq form eof)
	     collect (generate-ast form environment system))))))

(defun ast-from-file (filename environment system)
  (with-open-file (stream filename :direction :input)
    (ast-from-stream stream environment system)))

Use new function for processing forms read.


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

(defun error-to-body (e)
  "Convert the backtrace of E into a string."
  (check-type e error)
  (trivial-backtrace:print-backtrace e :output nil))

(defun handle-error (request next &key)
  "Execute the NEXT, catch the error it signaled, if any, and make a HTTP error response."
  (check-type request eloquent.mvc.request:<request>)
  (check-type next function)
  (handler-case (funcall next request)
    (error (e)
      (let ((body (error-to-body e)))
        (eloquent.mvc.response:respond
         body
         :headers '(:content-type "text/plain")
         :status 500)))))

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

(defun error-log (e)
  "Write the message and backtrace of E to error log file."
  (let ((body (error-to-body e)))
    (dolist (line (eloquent.mvc.prelude:split body #\Newline
                                              :remove-empty-subseqs t))
      (eloquent.mvc.logger:format
       :error "~A~%" line))))

(defun error-to-body (e)
  "Convert the backtrace of E into a string."
  (check-type e error)
  (trivial-backtrace:print-backtrace e :output nil))

;;; EXPORT

(defun handle-error (request next &key)
  "Execute the NEXT, catch the error it signaled, if any, and make a HTTP error response."
  (check-type request eloquent.mvc.request:<request>)
  (check-type next function)
  (handler-case (funcall next request)
    (error (e)
      (error-log e)
      (let ((body (error-to-body e)))
        (eloquent.mvc.response:respond
         body
         :headers '(:content-type "text/plain")
         :status 500)))))

Write error logs in HANDLE-ERROR

Write error logs in HANDLE-ERROR

The error signaled by its next procedures will be catched and print the
a error.log file


#| dummy system to make Quicklisp happy |#
(defsystem #:mcclim-fonts
  :components ((:file "common")))

(defsystem #:mcclim-fonts/truetype
    :depends-on (#:clim-basic #:zpb-ttf #:cl-vectors #:cl-paths-ttf #:cl-aa #:alexandria)
    :components ((:static-file "README.md")
                 (:file "truetype-package")
                 (:file "fontconfig" :depends-on ("truetype-package"))
                 (:file "mcclim-native-ttf" :depends-on ("truetype-package"))))

(defmethod perform :after ((o load-op)
                           (s (eql (find-system :mcclim-fonts/truetype))))
  (uiop:symbol-call :mcclim-truetype :autoconfigure-fonts))

(defsystem #:mcclim-fonts/clx-truetype
  :depends-on (#:mcclim-fonts/truetype #:mcclim-clx)
  :components ((:file "xrender-fonts")))

(defsystem #:mcclim-fonts/clx-freetype
  :depends-on (#:mcclim-fonts #:mcclim-clx #:cl-freetype2 #:mcclim-fontconfig #:mcclim-harfbuzz)
  :components ((:file "freetype")))

#| dummy system to make Quicklisp happy |#
(defsystem #:mcclim-fonts
  :depends-on (#:clim-basic)
  :components ((:file "common")))

(defsystem #:mcclim-fonts/truetype
    :depends-on (#:clim-basic #:zpb-ttf #:cl-vectors #:cl-paths-ttf #:cl-aa #:alexandria)
    :components ((:static-file "README.md")
                 (:file "truetype-package")
                 (:file "fontconfig" :depends-on ("truetype-package"))
                 (:file "mcclim-native-ttf" :depends-on ("truetype-package"))))

(defmethod perform :after ((o load-op)
                           (s (eql (find-system :mcclim-fonts/truetype))))
  (uiop:symbol-call :mcclim-truetype :autoconfigure-fonts))

(defsystem #:mcclim-fonts/clx-truetype
  :depends-on (#:mcclim-fonts/truetype #:mcclim-clx)
  :components ((:file "xrender-fonts")))

(defsystem #:mcclim-fonts/clx-freetype
  :depends-on (#:mcclim-fonts #:mcclim-clx #:cl-freetype2 #:mcclim-fontconfig #:mcclim-harfbuzz)
  :components ((:file "freetype")))

Fix build when trying to load various font sub-systems standalone

This remained unnoticed because these are always loaded as
dependencies of mcclim. The problem surfaces when these systems are
loaded standalone--since they use CLIM functions which are not
present. Adding CLIM-BASIC system as dependency fixes it.


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

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

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

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

Add name of new component to system definition.


;;;; nebula.asd

(asdf:defsystem #:nebula
  :serial t
  :description "Describe nebula here"
  :author "K. Isom <kyle@metacircular.net>"
  :license "MIT"
  :depends-on (#:cl-ppcre
	       #:cl-who
	       #:flexi-streams
	       #:ironclad
	       #:local-time
	       #:log4cl
	       #:postmodern
	       #:swank
	       #:restas
	       #:st-json
	       #:uuid)
  :components ((:file "package")
	       (:file "util")
	       (:file "blob")
	       (:file "entry")
	       (:file "db")
               (:file "nebula")))

;;;; nebula.asd

(asdf:defsystem #:nebula
  :serial t
  :description "Describe nebula here"
  :author "K. Isom <kyle@metacircular.net>"
  :license "MIT"
  :version 0.2.0
  :depends-on (#:cl-ppcre
	       #:cl-who
	       #:flexi-streams
	       #:ironclad
	       #:local-time
	       #:log4cl
	       #:postmodern
	       #:swank
	       #:restas
	       #:st-json
	       #:uuid)
  :components ((:file "package")
	       (:file "util")
	       (:file "blob")
	       (:file "entry")
	       (:file "db")
               (:file "nebula")))

Add version information to ASDF.

Add version information to ASDF.


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

(defun zerop (x)
  "Return T if the argument value is 0."
  (eq x 0))

(defun evenp (x)
  "Return T if x is an even number."
  (= 0 (mod x 2)))

(defun null (x)
  "Return T if argument is non-atomic."
  (listp x))

(defun endp (x)
  "Tests on end of a list (NIL)."
  (eq x nil))

(defun symbolp (x)
  "Tests if variable points to itself."
  (and (atom x)
	   (not (symbol-function x))
	   (eq x (symbol-value x))))

(defun variablep (x)
  (and (atom x)
	   (not (or (stringp x)
				(numberp x)))))

(defun keywordp (x)
  "Tests if symbol is in the keyword package."
  (and (atom x)
	   (eq (symbol-package x)
		   *keyword-package*)))

(define-test "NOT works with NIL"
  ((not nil))
  t)

(define-test "NOT works with T"
  ((not t))
  nil)

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

(defun zerop (x)
  "Return T if the argument value is 0."
  (eq x 0))

(defun evenp (x)
  "Return T if x is an even number."
  (= 0 (mod x 2)))

(defun null (x)
  "Return T if argument is non-atomic."
  (listp x))

(defun endp (x)
  "Tests on end of a list (NIL)."
  (eq x nil))

(defun symbolp (x)
  "Tests if variable points to itself."
  (if (and (atom x)
		   (not (= 0 (length (symbol-name x)))))
	  t))

(defun variablep (x)
  (and (atom x)
	   (not (or (stringp x)
				(numberp x)))))
; XXX ARRAYP ?

(defun keywordp (x)
  "Tests if symbol is in the keyword package."
  (and (atom x)
	   (eq (symbol-package x)
		   *keyword-package*)))

(define-test "NOT works with NIL"
  ((not nil))
  t)

(define-test "NOT works with T"
  ((not t))
  nil)

(define-test "KEYWORDP recognizes keyword-packaged symbols"
  ((keywordp :lisp))
  t)

(define-test "KEYWORDP works with standard symbols"
  ((keywordp 'lisp))
  nil)

Return T if atom has a name.

SYMBOLP: Return T if atom has a name.


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

(defvar *universe* nil)
(defvar *variables* nil)
(defvar *launchfile* nil)
(defvar *pointer-size* 4)
(defvar *assert* t)
(defvar *targets* '(:c :cl :js :php))
(defvar *endianess* nil)
(defvar *cpu-type* nil)
(defvar *libc-path* nil)
(defvar *rand-max* nil)
(defvar *print-definitions?* nil)
(defvar *default-stream-tabsize* 8)

(cl:defvar *macros* nil)

(defvar *quasiquoteexpand-hook* nil)
(defvar *dotexpand-hook* nil)

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

(defvar *universe* nil)
(defvar *variables* nil)
(defvar *launchfile* nil)
(defvar *pointer-size* 4)
(defvar *assert* t)
(defvar *targets* ,`',*targets*)
(defvar *endianess* nil)
(defvar *cpu-type* nil)
(defvar *libc-path* nil)
(defvar *rand-max* nil)
(defvar *print-definitions?* nil)
(defvar *default-stream-tabsize* 8)

(defvar *quasiquoteexpand-hook* nil)
(defvar *dotexpand-hook* nil)

Copy *TARGETS* from host environment.

Copy *TARGETS* from host environment.


(defpackage :things.utils
  (:documentation "Various useful and useless utils.")
  (:use #:cl)
  (:export #:qpush #:qpop))

(in-package :things.utils)

(defun qpush (queue item)
  "Pushes a value into a queue."
  (if queue
      (let ((n (list item)))
        (setf (cdr (cdr queue)) n)
        (setf (cdr queue) (last (cdr queue))))
      (let ((l (list item)))
        (setf queue (cons l (last l)))))
  nil)

(defun qpop (queue)
  "Pops a value from a queue."
  (let ((v (car (car queue))))
    (setf (car queue) (cdr (car queue)))
    v))

(defun qlength (queue)
  "Returns the size of the queue."
  (length (car queue)))

(defpackage :things.utils
  (:documentation "Various useful and useless utils.")
  (:use #:cl)
  (:export #:qpush #:qpop))

(in-package :things.utils)

(defun qpush (queue item)
  "Pushes a value into a queue."
  (if queue
      (let ((n (list item)))
        (setf (cdr (cdr queue)) n)
        (setf (cdr queue) (last (cdr queue))))
      (let ((l (list item)))
        (setf queue (cons l l))))
  queue)

(defun qpop (queue)
  "Pops a value from a queue."
  (let ((v (car (car queue))))
    (setf (car queue) (cdr (car queue)))
    v))

(defun qlength (queue)
  "Returns the size of the queue."
  (length (car queue)))

Set to return queue on push

Set to return queue on push


;; Common Lisp Script
;; Manoel Vilela

;; higher-order function sigma-sum
;; func must be a lambda(x) expression
(defun sigma-sum (func a b)
  (if (> a b)
      0
      (+ (funcall func a)
         (sigma-sum func (1+ a) b))))

(defun square (x)
  (* x x))

(sigma-sum #'(lambda(x) (/ 1 x)) 1 10)
(sigma-sum #'(lambda(x) (- x)) 1 10)

;; Common Lisp Script
;; Manoel Vilela

;; higher-order function sigma-sum
;; func must be a lambda(x) expression
(defun sigma-sum (func a b &key (next #'1+))
  (if (> a b)
      0
      (+ (funcall func a)
         (sigma-sum func (funcall next a) b))))

(defun square (x)
  (* x x))

(sigma-sum #'(lambda(x) (/ 1 x)) 1 10 :next #'(lambda (x) (+ 4 x)))
(sigma-sum #'(lambda(x) (- x)) 1 10)

Add optional paramater next as lambda expressions for sigma-sum


(cl:in-package #:clump-test)

(defun random-tree (&optional (node-probability 1.0))
  (if (< (random 1.0) node-probability)
      (make-instance 'node
	:data (random 20)
	:left (random-tree (* 0.9 node-probability))
	:right (random-tree (* 0.9 node-probability)))
      nil))

(cl:in-package #:clump-test)

(defun random-tree (node-class &optional (node-probability 1.0))
  (if (< (random 1.0) node-probability)
      (make-instance node-class
	:data (random 20)
	:left (random-tree node-class (* 0.9 node-probability))
	:right (random-tree node-class (* 0.9 node-probability)))
      nil))

Add required parameter for the class of the nodes to create.


(in-package #:euler)

(defun problem-1 ()
  (loop :for i :from 1 :below 1000
        :when (or (dividesp i 3)
                  (dividesp i 5))
        :sum i))

(defun problem-2 ()
  (loop :with p = 0
        :with n = 1
        :while (<= n 4000000)
        :when (evenp n) :sum n
        :do (psetf p n
                   n (+ p n))))

(defun problem-3 ()
  (apply #'max (prime-factorization 600851475143)))

(in-package #:euler)

(defun problem-1 ()
  ;; If we list all the natural numbers below 10 that are multiples of 3 or 5,
  ;; we get 3, 5, 6 and 9. The sum of these multiples is 23.
  ;;
  ;; Find the sum of all the multiples of 3 or 5 below 1000.
  (loop :for i :from 1 :below 1000
        :when (or (dividesp i 3)
                  (dividesp i 5))
        :sum i))

(defun problem-2 ()
  ;; Each new term in the Fibonacci sequence is generated by adding the previous
  ;; two terms. By starting with 1 and 2, the first 10 terms will be:
  ;;
  ;;     1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...
  ;;
  ;; By considering the terms in the Fibonacci sequence whose values do not
  ;; exceed four million, find the sum of the even-valued terms.
  (loop :with p = 0
        :with n = 1
        :while (<= n 4000000)
        :when (evenp n) :sum n
        :do (psetf p n
                   n (+ p n))))

(defun problem-3 ()
  ;; The prime factors of 13195 are 5, 7, 13 and 29.
  ;;
  ;; What is the largest prime factor of the number 600851475143 ?
  (apply #'max (prime-factorization 600851475143)))

Add comments with the Project Euler problem text


; bender – Copyright (c) 2014–2015 Sven Michael Klose <pixel@copei.de>

(defun assemble-parsed-files (x)
  (alet (assemble-multiple-passes x)
    (unless *unassigned-segment-blocks*
      (return !)))
  (format t "Assembling again to assign BLOCKs to SEGMENTS…~%")
  (sort-unassigned-segment-blocks)
  (with-temporary *assign-blocks-to-segments?* t
    (assemble-multiple-passes x :unassigned-segment-blocks *unassigned-segment-blocks*
                                :segments *segments*
                                :description " (assigning BLOCKs to SEGMENTs)")))

(defun assemble-files (out-name &rest in-names)
  (with-temporary *unassigned-segment-blocks* nil
    (let dump-name (+ out-name ".lst")
      (format t "Assembling to '~A'. Dump file is '~A'…~%" out-name dump-name)
      (with-output-file out out-name
        (with-output-file dump dump-name
          (with-temporary *assembler-dump-stream* dump
          (write-assembled-expressions (prog1 (assemble-parsed-files (parse-files in-names))
                                         (check-on-unassigned-blocks)
                                         (rewind-labels))
                                       out))))))
  nil)

; bender – Copyright (c) 2014–2015 Sven Michael Klose <pixel@copei.de>

(defun assemble-parsed-files (x)
  (alet (assemble-multiple-passes x)
    (unless *unassigned-segment-blocks*
      (return !)))
  (format t "Assembling again to assign BLOCKs to SEGMENTS…~%")
  (sort-unassigned-segment-blocks)
  (with-temporary *assign-blocks-to-segments?* t
    (assemble-multiple-passes x :unassigned-segment-blocks *unassigned-segment-blocks*
                                :segments *segments*
                                :description " (assigning BLOCKs to SEGMENTs)")))

(defun assemble-files (out-name &rest in-names)
  (with-temporary *unassigned-segment-blocks* nil
    (let dump-name (+ out-name ".lst")
      (format t "Assembling to '~A'. Dump file is '~A'…~%" out-name dump-name)
      (with-output-file out out-name
        (with-output-file dump dump-name
          (with-temporary *assembler-dump-stream* dump
          (write-assembled-expressions (prog1 (assemble-parsed-files (parse-files in-names))
                                         (check-on-unassigned-blocks)
                                         (rewind-labels)
                                         (= *pc* 0))
                                       out))))))
  nil)

Reset program counter before dumping the listing.


;;;; SPDX-License-Identifier: BSD-3-Clause

(in-package :text-analysis)

(defun word-tokenize (string &key (remove-stop-words t) (stem nil) (down-case t) (alphabeticp t))
  "Split a string into a list of words."
  (let* ((alpha-scanner (cl-ppcre:create-scanner "^[A-Za-z]*$"))
         (tokens (str:split " " (str:collapse-whitespaces string)))
         (tokens (if remove-stop-words
                     (delete-if (lambda (x) (gethash (string-downcase  x) (stop-words-lookup *language-data*))) tokens)
                     tokens))
         (tokens (if stem
                     (mapcar #'stem tokens)
                     tokens))
         (tokens (if down-case
                     (mapcar #'string-downcase tokens)
                     tokens))
         (tokens (if alphabeticp
                     (delete-if-not (lambda (x) (cl-ppcre:scan alpha-scanner x)) tokens)
                     tokens)))
    tokens))

(defun sentence-tokenize (string)
  "Split a string into a list of sentences."
  (remove "" (mapcar #'str:trim (cl-ppcre:split "\\.|\\?|\\!" string)) :test #'equal))

;;;; SPDX-License-Identifier: BSD-3-Clause

(in-package :text-analysis)

(defun word-tokenize (string &key (remove-stop-words t) (stem nil) (down-case t) (alphabetic t))
  "Split a string into a list of words."
  (let* ((alpha-scanner (cl-ppcre:create-scanner "^[A-Za-z]*$"))
         (tokens (str:split " " (str:collapse-whitespaces string)))
         (tokens (if remove-stop-words
                     (delete-if (lambda (x) (gethash (string-downcase  x) (stop-words-lookup *language-data*))) tokens)
                     tokens))
         (tokens (if stem
                     (mapcar #'stem tokens)
                     tokens))
         (tokens (if down-case
                     (mapcar #'string-downcase tokens)
                     tokens))
         (tokens (if alphabetic
                     (delete-if-not (lambda (x) (cl-ppcre:scan alpha-scanner x)) tokens)
                     tokens)))
    tokens))

(defun sentence-tokenize (string)
  "Split a string into a list of sentences."
  (remove "" (mapcar #'str:trim (cl-ppcre:split "\\.|\\?|\\!" string)) :test #'equal))

libraries/text-analysis: Rename ALPHABETICP to ALPHABETIC for consistency.

The other keyword arguments are also booleans but don't have the `p` suffix.


(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 "../../Conditionals/macros.lisp"))
(load (rp "../../Environment/standard-environment-macros.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"))

(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 "../../Data-and-control-flow/multiple-value-list.lisp"))
(load (rp "../../Data-and-control-flow/nth-value.lisp"))
(load (rp "../../Environment/defun.lisp"))
(load (rp "../../Conditionals/macros.lisp"))
(load (rp "../../Environment/standard-environment-macros.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 files containing recently-defined macros.