g000001

(cond-expand 
 (gauche (use util.match))
 (sagittarius (import (match)
                      (sagittarius control)
                      (time))))

(define (harropify x)
  (match x
    ((Op A B) (h Op (harropify A) (harropify B)))
    (A A)))

g000001

(defun badios (x)
  (ncase x . #.(mapcar (lambda (x) (list x `(* x x)))
                       (*:iota 100))))


(defun kadorto (x)
  (case x . #.(mapcar (lambda (x) (list x `(* x x)))
                      (*:iota 100))))

g000001

(defun plus (x y)
  (list x y))


(sb-c:defknown plus (cl:t cl:t) cl:t)


(sb-c:deftransform plus ((x y) (cl:string cl:string))
  '(cl:concatenate 'cl:string x y))

g000001

(cond-expand (sagittarius 
              (import (srfi :19) (srfi :1)))
             (gauche 
              (use srfi-1)
              (use srfi-19))
             (else #f))

(define (date-iota n :key (start (current-date)) (format "~m/~d(~a)"))
  (let ((stime (date->time-utc start))) 
    (define (datestr x)

g000001

;; http://blog.practical-scheme.net/shiro/20140518-alternating
(defun alternate (list &aux (x (list nil)) (y (list x)))
  (do ((u list) (y y)) ((endp u))
    (rplacd x (setq x (list (pop u))))
    (rplacd y (setq y (list (pop u)))))
  (list (cdr (pop y)) y))

(alternate (*:iota 100))
;=>  ((0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40 42 44 46 48 50 52
;      54 56 58 60 62 64 66 68 70 72 74 76 78 80 82 84 86 88 90 92 94 96 98)

g000001

(defun let1 (&quote var val &body body)
  (bind (value-cell-location var) (eval val))
  (do ((b body (cdr b)))
      ((null b) (eval (car b)))
    (eval (car b))))

g000001

(defclass person ()
  (name
   employed-by
   positions
   address
   phone-number))


(defclass organization ()
  (name

g000001

;;; hu.dwim.asdf / hu.dwim.asdf-20140211-darcs/source/system.lisp
#+sbcl
;; KLUDGE: TODO: this is an ugly hack to work around the bug https://bugs.launchpad.net/sbcl/+bug/501075
(sb-ext::without-package-locks
  (defun sb-impl::line-length (&optional (stream *standard-output*))
    (declare (ignore stream))
    160))

g000001

(defclass entity ()
  ((name :type string :accessor entity-name)
   (nicknames :type list
              :initform '()
              :accessor entity-nickname))) 


(defclass person (entity)
  ((phone-number :type phone-number)
   (organization :type organization)

g000001

(defconstant month-names 
  '#(() (January Jan)
    (February Feb)
    (March Mar)
    (April Apr)
    (May)
    (June Jun)
    (July Jul)
    (August Aug)
    (September Sept Sep)