Commit 1409b24f authored by Dave Cooper's avatar Dave Cooper

merging feature/zacl which adds support for zacl.

parents 0272a167 609ad61c
......@@ -367,3 +367,8 @@ set to nil to improve memory performance.")
(defparameter *with-format-element-type* nil
"Element-type. The default for the :element-type format-slot
for the base format. Defaults to nil. Needs a better default.")
(defparameter *allow-nil-list-of-numbers?* nil "Boolean. If set to t,
allows list-of-numbers function to return nil instead of error
when num1 is greater than num2 with positive increment or vice-versa.
Default is nil.")
......@@ -136,8 +136,10 @@ was contributed by Reinier van Dijk.
(tolerance (/ increment 10)) \"Number. tolerance for increment.\")"
(cond ((zerop increment) (error "increment of zero is not allowed"))
((and (< increment 0.0) (> num2 num1)) (error "increment is negative, while difference between num2 and num1 is positive."))
((and (> increment 0.0) (< num2 num1)) (error "increment is positive, while difference between num2 and num1 is negative."))
((and (< increment 0.0) (> num2 num1))
(unless *allow-nil-list-of-numbers?* (error "increment is negative, while difference between num2 and num1 is positive.")))
((and (> increment 0.0) (< num2 num1))
(unless *allow-nil-list-of-numbers?* (error "increment is positive, while difference between num2 and num1 is negative.")))
(t (let ((predicate (if (> increment 0.0) #'>= #'<=))
(result-list nil))
(do ((num num1 (+ num increment)))
......@@ -193,6 +193,7 @@ If you are interested in this effort we would love to hear from you at open-sour
......@@ -397,6 +398,7 @@ If you are interested in this effort we would love to hear from you at open-sour
......@@ -67,6 +67,7 @@
(defun quicklisp-copyright-string ()
(when *already-loaded-systems*
(let ((ql-libs
(set-difference *already-loaded-systems*
......@@ -74,28 +75,16 @@
"monofasl" "pro" "enterprise")
:key #'string :test #'string-equal) #'string-lessp))
(ql-version (with-open-file (in (or (probe-file
(merge-pathnames "quicklisp/dists/quicklisp/distinfo.txt"
(merge-pathnames "genworks/quicklisp/dists/quicklisp/distinfo.txt"
(merge-pathnames "quicklisp/dists/quicklisp/distinfo.txt"
(merge-pathnames "../distinfo.txt"
(read-line in)
(string-trim (list #\space) (second (glisp:split-regexp ":" (read-line in)))))))
(ql-version (with-open-file (in (or (probe-file (merge-pathnames "dists/quicklisp/distinfo.txt" *quicklisp-home*))
(error "Quicklisp directory not found in gendl:*quicklisp-home*,
which is set to: ~a.~%" *quicklisp-home*)))
(read-line in) (string-trim (list #\space) (second (glisp:split-regexp ":" (read-line in)))))))
(format nil "Also contains the following Common Lisp libraries
from Quicklisp version ~a, whose source files are available in the
Quicklisp repository at, Copyright© their
respective authors:
~{~a~^, ~}.~%"
~{~a~^, ~}.~%" ql-version ql-libs))))
(defun startup-banner ()
......@@ -30,8 +30,14 @@
:directory (butlast (pathname-directory glisp:*gdl-program-home*))
:defaults glisp:*gdl-program-home*))
(setq glisp:*gendl-home* glisp:*gdl-home*)
(setq *quicklisp-home* (or (probe-file (merge-pathnames "quicklisp/" glisp:*gendl-home*))
(probe-file (merge-pathnames "genworks/quicklisp/" glisp:*gendl-home*))))
(setq *quicklisp-home* (or (when (and (find-package :ql) (boundp (read-from-string "ql:*quicklisp-home*")))
(symbol-value (read-from-string "ql:*quicklisp-home*")))
(probe-file (merge-pathnames "quicklisp/" glisp:*gendl-home*))
(probe-file (merge-pathnames "genworks/quicklisp/" glisp:*gendl-home*))
(probe-file (merge-pathnames "quicklisp/" glisp:*genworks-source-home*))
(probe-file (merge-pathnames "genworks/quicklisp/dists/quicklisp/distinfo.txt"
(pushnew (make-keyword (format nil "gendl-~a" *gendl-version*)) *features*)
;; Copyright 2002, 2009 Genworks International and Genworks BV
;; Copyright 2002, 2009 Genworks International
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
......@@ -370,10 +370,8 @@
((:div :id "copyright")
(when gwl:*developing?*
(the write-development-links))
"Copyright &copy; 2012 "
"Copyright &copy; 2016 "
((:a :href "") "Genworks" (:sup "&reg;") "International")
" and "
((:a :href "") "Delft University of Technology")
"(:base :uiop :cl-typesetting :cl-ppcre :cl-who #-allegro :cl-base64 #-allegro :babel #-allegro :acl-compat)"
"(:base :uiop :cl-typesetting :cl-ppcre :cl-who #-allegro :cl-base64 #-allegro :babel #-(or allegro ccl) :acl-compat #+ccl :zacl)"
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:glisp :description
"The Gendl\" Common Lisp Portability" :author "John McCarthy"
:license "Affero Gnu Public License ("
:serial t :version "20160828" :depends-on
(:base :uiop :cl-typesetting :cl-ppcre :cl-who #-allegro :cl-base64 #-allegro :babel #-allegro :acl-compat)
"The Gendl® Common Lisp Portability" :author b :license
"Genworks Proprietary" :serial t :version "20161127" :depends-on
(:base :uiop :cl-typesetting :cl-ppcre :cl-who #-allegro :cl-base64 #-allegro :babel #-(or allegro ccl) :acl-compat #+ccl :zacl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......@@ -268,23 +268,6 @@ The command line was: ~%~%~s~%" command result error command-line)))))
(unless (zerop result) (error "Ghostscript threw error"))))
(defun run-gs (command)
"Shell out a ghostscript command and handle errors."
(format t "~a" command)
(let ((result (#+allegro
;;:show-window :hide
(when result
(unless (zerop result) (error "Ghostscript threw error")))))
(defun run-program (command &rest keys
&key ignore-error-status force-shell
......@@ -439,11 +422,34 @@ the \"current\" error."
(defun local-port (socket)
(#+(or allegro zacl) socket:local-port #-(or allegro zacl) acl-compat.socket:local-port socket))
(defun local-port (socket)
#-allegro acl-compat.socket:local-port socket))
(defun match-regexp (string-or-regexp string-to-match
&key newlines-special case-fold return
(start 0) end shortest)
(when (or newlines-special case-fold return shortest)
(error "keyword arguments :newlines-special, :case-fold, :return, and :shortest
are no longer supported by glisp:match-regexp.~%"))
#+allegro (excl:match-regexp string-or-regexp string-to-match :start start :end end)
#-allegro (let ((end-default (or end (length string-to-match))))
(cl-ppcre:scan string-or-regexp string-to-match :start start :end end-default)))
(defun match-regexp (string-or-regexp string-to-match
&key newlines-special case-fold return
(start 0) end shortest)
......@@ -459,6 +465,16 @@ the \"current\" error."
(defun patches-dir ()
(defun process-run-function (name-or-options preset-function &rest args)
#-allegro (when args (error "args not supported for glisp:process-run-function on ~a.~%" (lisp-implementation-type)))
(apply #+allegro #'mp:process-run-function
#-allegro #'bt:make-thread preset-function name-or-options))
(defun process-run-function (name-or-options preset-function &rest args)
(apply #+allegro #'mp:process-run-function
#-allegro #'
......@@ -471,8 +487,13 @@ the \"current\" error."
(defun remote-host (socket)
#+allegro (socket:remote-host socket)
#-allegro (acl-compat.socket:remote-host socket))
#+(or allegro zacl) (socket:remote-host socket)
#-(or allegro zacl) (acl-compat.socket:remote-host socket))
(defun local-host (socket)
#+(or allegro zacl) (socket:local-host socket)
#-(or allegro zacl) (acl-compat.socket:local-host socket))
(defun replace-regexp (string regexp to-string)
(cl-ppcre:regex-replace-all regexp string to-string))
......@@ -651,16 +672,17 @@ please find implementation for the currently running lisp.~%")
#-allegro `(let ((*print-case* :downcase)) ,@body)
#+allegro `(progn ,@body))
(defun with-timeout-sym ()
"Returns the appropriate symbol for with-timeout, for substitution within macros."
#+allegro 'sys:with-timeout
#-allegro '
#+(or allegro zacl) 'sys:with-timeout
#-(or allegro zacl) '
(defmacro with-timeout ((seconds &body timeout-body) &body body)
#+allegro `(mp:with-timeout (,seconds ,@timeout-body)
#-allegro `( (,seconds ,@timeout-body)
#+(or allegro zacl) `(sys:with-timeout (,seconds ,@timeout-body) ,@body)
#-(or allegro zacl) `( (,seconds ,@timeout-body) ,@body))
(defmacro without-redefinition-warnings (&rest body)
......@@ -409,7 +409,7 @@ running the Javascript interpreter to evaluate (the js-to-eval), if any.
js-vals (glisp:replace-regexp js-vals "\\" "\\\\\\\\"))
(format nil "gdlAjax(~a, 'args=~a~a~a, ~a);"
(format nil "gdlAjax(~a, 'args=~a~a~a, ~a); return(false);"
(if null-event? "null" "event") string-1 string-2 (or js-vals "") string-3)))
(:bordeaux-threads :glisp :aserve :yason)
"(:bordeaux-threads :drakma :glisp #+ccl :aserve #-ccl :paserve :yason)"
......@@ -39,6 +39,9 @@ Defaults to nil."
("Keyword symbol. The ID attribute for this tag. Defaults to (the field-name)."
id (the field-name))
("Keyword symbol. The name of this field. Computed from the object name within the tree."
field-name (make-keyword-sensitive (the base64-encoded-root-path)))
......@@ -66,8 +69,7 @@ Previously known as form-control-string. Default is the form-control-string."
(with-format (html-format *stream*)
(write-the string))))
("Keyword symbol. The name of this field. Computed from the object name within the tree."
field-name (make-keyword-sensitive (the base64-encoded-root-path)))
......@@ -3,9 +3,10 @@
(asdf:defsystem #:gwl :description
"The Gendl® Generative Web Language (GWL)" :author "John McCarthy"
:license "Affero Gnu Public License ("
:serial t :version "20161025" :depends-on
(:bordeaux-threads :glisp :aserve :yason)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
:serial t :version "20161125" :depends-on
(:bordeaux-threads :drakma :glisp #+ccl :aserve #-ccl :paserve :yason)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings )
#+asdf-unicode :defsystem-depends-on #+asdf-unicode ()
#+asdf-encodings :encoding #+asdf-encodings :utf-8
((:file "source/package") (:file "source/with-all-servers")
......@@ -16,10 +17,9 @@
(:file "source/utilities") (:file "source/answer")
(:file "source/accessories") (:file "source/gdl-remote")
(:file "source/vanilla-remote") (:file "source/base64-utils")
(:file "source/cl-pdf-patches") (:file "source/color-palette")
(:file "source/crawler") (:file "source/log-utils")
(:file "source/new-urls") (:file "source/publish")
(:file "source/remote-object")
(:file "source/color-palette") (:file "source/crawler")
(:file "source/log-utils") (:file "source/new-urls")
(:file "source/publish") (:file "source/remote-object")
(:file "source/security-check-failed")
(:file "form-elements/source/grid-form-element")
(:file "form-elements/source/macros")
......@@ -104,8 +104,8 @@ object.")
;;(respondent (the bashee) :defaulting)
(respondent (the bashee))
(respondent (the bashee) :defaulting)
;;(respondent (the bashee))
("GDL object. Default object to which control will return with the write-back-link method"
return-object (the :parent))
;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for the details
;;; You can reach me at or
;;; The homepage of cl-pdf is here:
(in-package :pdf)
(defmethod write-object ((obj indirect-object) &optional root-level)
(gdl:print-variables *pdf-stream*)
(if root-level
(vector-push-extend (format nil "~10,'0d ~5,'0d n "
;;FLAG -- DJC added conditional for allegro to handle aserve streams
#+allegro (typecase *pdf-stream*
(force-output *pdf-stream*)
(excl::socket-bytes-written *pdf-stream*))
(otherwise (file-position *pdf-stream*)))
#+lispworks (if (typep *pdf-stream* 'acl-compat.socket::bidirectional-binary-socket-stream)
(progn (force-output *pdf-stream*)
(acl-compat.socket::stream-file-position *pdf-stream*))
(file-position *pdf-stream*))
#-(or allegro lispworks) (file-position *pdf-stream*)
(gen-number obj))
(format *pdf-stream* "~d ~d obj~%" (obj-number obj)(gen-number obj))
(when (content obj)(write-object (content obj)))
(write-string "endobj" *pdf-stream*)
(write-char #\Newline *pdf-stream*))
(format *pdf-stream* "~d ~d R" (obj-number obj)(gen-number obj))))
(defmethod write-document ((s stream) &optional (document *document*))
(gdl:print-variables s)
(let ((*xrefs* (make-array 10 :adjustable t :fill-pointer 0))
(*pdf-stream* s))
#+lispworks (if (typep s 'acl-compat.socket::bidirectional-binary-socket-stream)
(setf acl-compat.socket::*socket-bytes-written* 0))
(let ((*read-default-float-format* 'double-float))
(process-outlines document)
(vector-push-extend "0000000000 65535 f " *xrefs*)
(write-line +pdf-header+ *pdf-stream*)
(loop for obj across (objects document)
for first = t then nil
if obj do (write-object obj t)
else do (unless first (vector-push-extend "0000000000 00001 f " *xrefs*)))
;;(setf startxref (file-position s))
(setf startxref #+allegro (typecase *pdf-stream*
((excl::hiper-socket-stream net.aserve::chunking-stream)
(force-output *pdf-stream*)
(excl::socket-bytes-written *pdf-stream*))
(otherwise (file-position *pdf-stream*)))
#+lispworks (if (typep s 'acl-compat.socket::bidirectional-binary-socket-stream)
(progn (force-output s)
(acl-compat.socket::stream-file-position s))
(file-position s))
#-(or allegro lispworks) (file-position s))
(unless startxref (setf startxref (file-position s)))
(format *pdf-stream* "xref~%0 ~d~%" (length *xrefs*))
(loop for xref across *xrefs*
do (write-line xref s))
(format s "trailer~%<< /Size ~d~%/Root " (length *xrefs*)) ;(1- (length (objects document))))
(write-object (catalog document))
(when (docinfo document)
(format s " /Info ")
(write-object (docinfo document)))
(format s "~%>>~%startxref~%~d~%%%EOF~%" startxref))))
......@@ -282,11 +282,7 @@
;; FIXME: better way to get this ?
(when (boundp '*wserver*)
(let ((sock (wserver-socket *wserver*)))
(when sock
(socket:local-host sock)
(acl-compat.socket:local-host sock)))))
(when sock (glisp:local-host sock)))))
(defun encode-object-for-http (item id)
(list :remote-gdl-instance
* X3DOM JavaScript Library
* (C)2009 Fraunhofer IGD, Darmstadt, Germany
* Dual licensed under the MIT and GPL
* Based on code originally provided by
* Philip Taylor:
body {
background-color: white;
font-family: Helvetica, sans-serif;
font-size: 12px;
X3D, x3d {
position:relative; /* in order to be able to position stat-div within X3D */
float:left; /* float the element so it has the same size like the canvas */
margin: 0;
padding: 0;
border: 1px solid #000;
object {
margin: 0;
padding: 0;
border: none;
z-index: 0;
.x3dom-canvas:hover {
-webkit-user-select: none;
-webkit-touch-callout: none;
.x3dom-canvas {
.x3dom-canvas-mousedown {
.x3dom-canvas:focus {
.x3dom-progress {
margin: 0;
padding: 6px 8px 0px 26px;
left: 0px;
top: 0px;
position: absolute;
color: #0f0;
font-family: Helvetica, sans-serif;
font-size: 10px;
min-width: 45px;
min-height: 20px;
border: 0px;
background-position: 4px 4px;
background-repeat: no-repeat;
background-color: #333;
background-color: rgba(51, 51, 51, 0.9);
z-index: 100;
} span {
position: absolute;
left: 0;
top: 0;
line-height: 20px;
background-color: red;
.x3dom-statdiv {
margin: 0;
padding: 0;
right: 10px;
top: 10px;
position: absolute;
color: #0f0;
font-family: Helvetica, sans-serif;
font-size: 10px;
width: 75px;
height: 70px;
border: 0px;
#x3dom-state-canvas {
margin: 2px;
padding: 0;
right: 0%;
top: 0%;
position: absolute;
#x3dom-state-viewer {
position: absolute;
margin: 2px;
padding: 5px;
width: 135px;
top: 0%;
right: 0%;
opacity: 0.9;
background-color: #323232;
z-index: 1000;
font-family: Arial, sans-serif;
color: #C8C8C8;
font-weight: bold;
text-transform: uppercase;
cursor: help;
.x3dom-states-head {
display: block;
font-size: 26px;
.x3dom-states-rendermode-software {
font-size: 10px;
margin: 0 0 2px 2px;
.x3dom-states-rendermode-hardware {
font-size: 10px;
margin: 0 0 2px 2px;
.x3dom-states-head2 {
font-size: 10px;
.x3dom-states-list {
float: left;
width: 100%;
border-top: 1px solid #C8C8C8;
list-style: none;
font-size: 9px;
line-height: 16px;
padding: 0;
padding-top: 2px;
.x3dom-states-item {
width: 100%;
float: left;
.x3dom-states-item-title {
float: left;
margin-left: 2px;
.x3dom-states-item-value {
float: right;
margin-right: 2px;
.x3dom-touch-marker {
display: inline;
padding: 5px;
border-radius: 10px;
position: absolute;
font-family: Helvetica, sans-serif;
font-size: 10px;
color: darkorange;
background: cornsilk;
opacity: 0.6;
border: 2px solid orange;
z-index: 200;
.x3dom-logContainer {
border: 2px solid olivedrab;
height: 200px;
padding: 4px;
overflow: auto;
white-space: pre-wrap;
font-family: sans-serif;
font-size: x-small;
color: #00ff00;
background-color: black;
margin-right: 10px;
.x3dom-nox3d {
font-family: Helvetica, sans-serif;
font-size: 14px;
background-color: #eb7a7a;
padding: 1em;
opacity: 0.75;
.x3dom-nox3d p {
color: #fff;
font-size: 14px;
.x3dom-nox3d a {
color: #fff;
font-size: 14px;
/* self-clearing floats */
.group:after {
content: ".";
display: block;
height: 0;
clear: both;
visibility: hidden;
This diff is collapsed.
X3DOM has been developed by Fraunhofer IGD (VCST group).
Contributions to core X3DOM components:
* Johannes Behr
* Yvonne Jung
* Timo Sturm
* Andreas Aderhold
* Katarzyna Wilkosinska
* Max Limper
* Maik Thoener
* Christian Stein
* Tobias Franke
* Peter Eschler
* Timm Drevensek
Contributions to shadow mapping:
* Nicolas Eicke
Contributions to BVHRefiner component:
* Michael Englert
Contributions to the CAD component:
* Don Brutzman <>
* Vincent Marchetti <>
* "이효광 (Hyokwang Lee)" <>
* Joe D Williams <>
Contributions to the Geo component:
* "Byounghyun Yoo (유병현)" <>
* Andreas Plesch <>
Other much-appreciated contributors:
* x3domer
* James Sweet
* John Congote
* Ander Arbelaiz <>
* Yurai Núñez-Rodríguez <>
* ...
* Your Name <>
A big thank you to Philip Taylor. X3DOM is originally based on his first prototypical implementation of a scene graph in HTML 5.
This diff is collapsed.
Dual licensed under the MIT and GPL licenses.
Copyright (c) 2009 X3DOM
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, mo