10. Subroutines

;;;-----------------------------
(defparameter *greeted* 0)              ; global variable
(defun hello ()
  (incf *greeted*)
  (format t "hi there!~%"))
;;;-----------------------------
(hello)           ; call subroutine hello with no arguments/parameters
;;;-----------------------------

;;;-----------------------------
;; It would be strange to declare arguments using &rest when you know
;; there are exactly two, in CL, but you could, if you wanted to
;; emulate what the Perl example does.
(defun hypotenuse (&rest args)
  (sqrt (+ (expt (elt args 0) 2) 
           (expt (elt args 1) 2))))

(setf diag (hypotenuse 3 4))            ; DIAG is 5.0
;;;-----------------------------
(defun hypotenuse (side1 side2)
  (sqrt (+ (expt side1 2) 
           (expt side2 2))))
;;;-----------------------------
(format t "~D~%" (truncate (hypotenuse 3 4))) ; prints 5

(let ((a '(3 4)))
  (format t "~D~%" (truncate (apply 'hypotenuse a)))) ; prints 5
;;;-----------------------------
(setf both (append men women))
(setf both `(,@men ,@women)) ; alternative way of doing the same thing
;;;-----------------------------
(setf nums '(1.4 3.5 6.7))
(setf ints (apply 'int-all nums))       ; NUMS unchanged
(defun int-all (&rest retlist)
  (loop for n in retlist collect (truncate n)))
;;;-----------------------------
(setf nums '(1.4 3.5 6.7))
(trunc-em nums)                         ; NUMS now (1 3 6)
(defun trunc-em (reals)
  (map-into reals 'truncate reals))     ; truncate each element of arg list
;;;-----------------------------

;;;-----------------------------
(defun somefunc ()
  (let (variable              ; VARIABLE is invisible outside SOMEFUNC
        another an-array a-hash)    ; declaring many variables at once
    ;; ...
    ))
;;;-----------------------------
(destructuring-bind (name age) *posix-argv*
  ;; Use NAME, AGE here
  )

(setf start (fetch-time))
;;;-----------------------------
(destructuring-bind (a b) pair
  (let ((c (fetch-time)))
    ;; ...
    ))

(defun check-x (x)
  (let ((y "whatever"))
    (run-check)
    (when condition
      (format t "got ~A~%" x))))
;;;-----------------------------
(defun save-array (&rest arguments)
  ;; There's probably a better way to do this.
  (setf *global-array* (append *global-array* (copy-seq arguments))))
;;;-----------------------------

;;;-----------------------------
(let (variable)
  (defun mysub ()
    ;; ... accessing VARIABLE
    ))
;;;-----------------------------
(let ((variable 1))
  (defun othersub ()
    ;; ... accessing VARIABLE
    ))
;;;-----------------------------
(let ((counter 0))
  (defun next-counter ()
    (incf counter)))
;;;-----------------------------
(let ((counter 42))
  (defun next-counter ()
    (incf counter))
  (defun prev-counter ()
    (decf counter)))
;;;-----------------------------

;;;-----------------------------
;; There is no standard equivalent of Perl's caller(), in CL.
;; Functions can get inlined (among other things), so it's not even
;; clear what something like caller() should actually return, anyway.
;;;-----------------------------

;;;-----------------------------
(array-diff array1 array2)              ; params are already references
;;;-----------------------------
(setf a #(1 2))
(setf b #(5 8))
(setf c (add-vecpair a b))
(format t "~{~A~^ ~}~%" (map 'list 'identity c))
;; 6 10

;; This function would be simpler with lists instead of arrays, or the
;; use of the SERIES package.  We're using arrays because the Perl
;; does.
(defun add-vecpair (x y)        ; assumes both vectors the same length
  (map-into (make-array (length x))
            '+ x y))
;;;-----------------------------
;; Normally one would use CHECK-TYPE or ASSERT here, but this example
;; is trying to match the Perl.
(unless (and (typep x 'vector)
             (typep y 'vector))
  (error "usage: add_vecpair VECTOR1 VECTOR2"))
;;;-----------------------------

;;;-----------------------------
;; There is no equivalent to Perl's wantarray() in CL.  The most
;; similar language feature is CL's ability to return multiple values,
;; which the caller may choose to ignore.
;;;-----------------------------

;;;-----------------------------
(thefunc :increment "20s" :start "+5m" :finish "+30m")
(thefunc :start "+5m" :finish "+30m")
(thefunc :finish "+30m")
(thefunc :start "+5m" :increment "15s")
;;;-----------------------------
;; &allow-other-keys is used to emulate the Perl example's use of @_
;; in the %args hash.
(defun thefunc (&key (increment "10s") finish start &allow-other-keys)
  (when (scan "m$" increment)
    ;; ...
    ))
;;;-----------------------------

;;;-----------------------------
;; Use of gensym here is unusual, just trying to mimic the Perl (there
;; is probably a better way to do that, too).  Also, normally you'd do
;; MULTIPLE-VALUE-BIND.
(multiple-value-setq (a #.(gensym) c) (func))
;;;-----------------------------
;; I don't know of a quicker built-in way to do exactly what the Perl
;; is doing here.  There is NTH-VALUE but it only returns one value.
(let ((results (multiple-value-list (func))))
  (setf a (elt results 0)
        c (elt results 2)))

;; However you can easily define a macro that does roughly the same
;; thing.
(defmacro nth-values ((&rest positions) &body body)
  (let ((results (gensym "results-")))
    `(let ((,results (multiple-value-list ,@body)))
       (values
        ,@(mapcar #'(lambda (pos) `(elt ,results ,pos)) positions)))))

(multiple-value-setq (a c) (nth-values (0 2) (func)))
;;;-----------------------------
#+sbcl
(multiple-value-setq (dev ino dummy dummy uid)  (sb-unix:unix-stat filename))
;;;-----------------------------
#+sbcl
(multiple-value-setq (dev ino #.(gensym) #.(gensym) uid)  (sb-unix:unix-stat filename))
;;;-----------------------------
;; Using the non-standard NTH-VALUES macro defined above.
#+sbcl
(multiple-value-setq (dev ino uid gid) (nth-values (0 1 4 5) (sb-unix:unix-stat filename)))
;;;-----------------------------

;;;-----------------------------
(multiple-value-setq (array hash) (somefunc))

(defun somefunc ()
  (let ((array (make-array ...))
        (hash (make-hash-table ...)))
    ;; ...
    (values array hash)))
;;;-----------------------------
(defun fn ()
  ;; ...
  (values a b c))                 ; assuming a, b and c are all hashes
;;;-----------------------------
(multiple-value-setq (h0 h1 h2) (fn))   ; unlike Perl example, not "wrong"
(setf list-of-hashes (multiple-value-list (fn))) ; eg: (gethash "keystring" (elt list-of-hashes 2))
(multiple-value-setq (r0 r1 r2) (fn)) ; everything's a reference, no difference from previous
;;;-----------------------------

;;;-----------------------------
;; In CL everything returns a value.
;;;-----------------------------
(defun empty-retval ())                 ; returns nil
;; If you want to distinguish between returning "empty" vs "undefined"
;; then you can return return a second value indicating which.
(defun empty-retval ()
  (values nil nil))
;;;-----------------------------
(let ((a (yourfunc)))
  (when a
    ;; ...
    ))
;;;-----------------------------
;; The following are all the same, just mirroring the Perl here.
(let ((a (sfunc)))
  (unless a
    (error "sfunc failed")))

(let ((a (afunc)))
  (unless a
    (error "afunc failed")))

(let ((a (hfunc)))
  (unless a
    (error "hfunc failed")))
;;;-----------------------------
;; Note: this is for illustrating the use of OR and ERROR, there is no
;; built-in ioctl or strerror in CL.
(or (ioctl ...) (error "can't ioctl: ~A" strerror))
;;;-----------------------------

;;;-----------------------------
(setf results (myfunc 3 5))
;;;-----------------------------
;; Unlike Perl, you can't call functions without using outer parens
;; (unless you develop macros to let you do so in specific
;; circumstances)
(setf results (myfunc 3 5))
;;;-----------------------------
;;;-----------------------------
(setf results `(,@(myfunc 3) 5))
;;;-----------------------------
(defun lock-sh () 1)
(defun lock-ex () 2)
(defun lock-un () 4)
;;;-----------------------------
(defun mypush (list &rest remainder)
  ;; ...
  )
;;;-----------------------------
(mypush (if (> x 10) a b) 3 5)          ; unlike Perl, not wrong
;;;-----------------------------
;; Params are already passed as references in CL
;;;-----------------------------
(defun hpush (href &rest keys-and-values)
  (loop
     for k in keys-and-values by #'cddr
     for v in (cdr keys-and-values) by #'cddr
     do (setf (gethash k href) v))
  href)                                 ; return this for caller's convenience

(hpush pieces "queen" 9 "rook" 5)
;;;-----------------------------

;;;-----------------------------
(error "some message")                  ; raise exception
;;;-----------------------------
(multiple-value-bind (result condition)
    (ignore-errors (eval (func)))
  (when condition (warn "func raised an exception: ~A" condition)))
;;;-----------------------------
(multiple-value-bind (result condition)
    (ignore-errors (eval (setf val (func))))
  (when condition (warn "func blew up: ~A" condition)))
;;;-----------------------------
(multiple-value-bind (result condition)
    (ignore-errors (eval (setf val (func))))
  (when condition (warn "func blew up: ~A" condition)))
;;;-----------------------------
(multiple-value-bind (result condition)
    (ignore-errors (eval (setf val (func))))
  (when (and condition
             (not (scan "Full moon" 
                                 ;; There's probably a better way to
                                 ;; do this.
                                 (format nil "~A" condition))))
    (warn "func blew up: ~A" condition)))
;;;-----------------------------
;; No equivalent to wantarray().
;;;-----------------------------

;;;-----------------------------
(defparameter *age* 18)                 ; global variable
(when CONDITION
  (let ((*age* 23))
    (func)                              ; sees temporary value of 23
    )) ; restore old value at block exit
;;;-----------------------------
(setf para (get-paragraph fh))
(defun get-paragraph (fh)
  ;; Skip leading newlines.
  (loop for peek = (peek-char nil fh nil nil)
     while (and peek (eql peek #\Newline))
     do (read-char fh nil nil))
  (chomp
   (coerce (loop 
              for c = (read-char fh nil :eof)
              until (or (eq c :eof)
                        (and (eql c #\Newline)
                             (eql (peek-char nil fh nil #\Newline)
                                  #\Newline)))
              collect c)
           'string)))
;;;-----------------------------
(setf contents (get-motd))
(defun get-motd ()
  (with-open-file (motd "/etc/motd") ; will do die()-like stuff automatically
    (coerce (loop
               for c = (read-char motd nil :eof)
               until (eq c :eof)
               collect c)
            'string)))
;;;-----------------------------
;;;-----------------------------
;; Note: in the spirit of the Perl, this section should be done using
;; LET and DECLARE SPECIAL but I couldn't get that to work.
(defparameter *nums* '(0 1 2 3 4 5))

(defun my-second ()     ; don't redefine CL's standard SECOND function
  (format t "~{~A~^ ~}~%" *nums*))

(defun my-first ()
  (let ((*nums* (copy-list *nums*)))
    (setf (elt *nums* 3) 3.14159)
    (my-second)))

(my-second)
;; 0 1 2 3 4 5
(my-first)
;; 0 1 2 3.14159 4 5
;;;-----------------------------
;; No obvious equivalent to %SIG
;;;-----------------------------

;;;-----------------------------
;;; @@INCOMPLETE@@

;;;-----------------------------
(fmakunbound 'grow) ; not sure this is necessary, but more like the Perl
(setf (symbol-function 'grow) #'expand)
(grow)                                  ; calls EXPAND
;;;-----------------------------
(setf one:var two:table)                ; make ONE:VAR alias for TWO:TABLE
(setf (symbol-function 'one:big) #'two:small) ; make ONE:BIG alias for TWO:SMALL
;;;-----------------------------
(let ((fred #'barney))              ; temporarily alias FRED to BARNEY
  ;; ...
  )
;;;-----------------------------
(setf string (red "careful here"))
(format t "~A" string)
;; <FONT COLOR='red'>careful here</FONT>
;;;-----------------------------
(defun red (string)
  (concatenate 'string "<FONT COLOR='red'>" string "</FONT>"))
;;;-----------------------------
(defmacro color-font (color)
  `(defun ,(intern (string-upcase color)) (string)
     (concatenate 'string "<FONT COLOR='" ,color "'>" string "</FONT>")))

(color-font "red")
(color-font "green")
(color-font "blue")
(color-font "purple")
;; etc
;;;-----------------------------
(defmacro color-fonts (&rest colors)
  (append '(progn)
          (loop for color in colors
             collect `(color-font ,color))))

(color-fonts "red" "green" "blue" "yellow" "orange" "purple" "violet")
;;;-----------------------------

;;;-----------------------------
(defun outer (arg)
  (let* ((x (+ arg 35))
         ;; You're much less likely to do this accidentally in CL, but
         ;; I'm trying to match the spirit of the Perl example.
         (inner (block nil
                  (return (* x 19)))))  ; WRONG
    (+ x (inner))))
;;;-----------------------------
(defun outer (arg)
  (let ((x (+ arg 35)))
    (flet ((inner () (* x 19)))
      (+ x (inner)))))
;;;-----------------------------

;;;-----------------------------

(defgeneric cmp (a b)
  (:documentation "Vaguely like Perl's cmp() function."))

(defmethod cmp ((a string) (b string))
  (cond
    ((string= a b) 0)
    ((string-lessp a b) -1)
    (t 1)))

(defmethod cmp ((a number) (b number))
  (cond
    ((= a b) 0)
    ((< a b) -1)
    (t 1)))

(defmethod cmp (a b)
  0)

(defun bysub1 (&rest filenames)
  (let ((sub (make-array 0 :fill-pointer 0))
        (msgs (make-array 0 :fill-pointer 0)))
    (dolist (filename filenames)
      (with-open-file (file filename)
        ;; GET-PARAGRAPH defined in section 10.13
        (loop
           for paragraph = (get-paragraph file)
           until (string-equal paragraph "")
           do (when (scan (create-scanner #?r"^From" :multi-line-mode t) 
                          paragraph)
                (vector-push-extend
                 (or
                  (register-groups-bind (subject)
                      ((create-scanner #?r/^Subject:\s*(?:Re:\s*)*(.*)/
                                       :case-insensitive-mode t :multi-line-mode t)
                       paragraph)
                    (string-downcase subject))
                  "")
                 sub))
           (vector-push-extend paragraph msgs))))
    (let ((indices (make-array (length msgs)
                               :initial-contents (loop
                                                    for i below (length msgs) 
                                                    collect i))))
      (sort indices #'(lambda (a b)
                        (case (if (and (< a (length sub)) (< b (length sub)))
                                  (cmp (aref sub a) (aref sub b))
                                  0)
                          (0 (< a b))
                          (-1 t))))
      (map nil #'(lambda (i)
                   (format t "~A~%" (aref msgs i)))
           indices))))

;; bysub2 illustrates a Perl-specific idiom and will be skipped.

(defun print-hash-table (hashtable)
  "Useful for debugging."
  (loop
     for key being the hash-keys of hashtable using (hash-value value)
     do (format t "~A: ~A~%" key value)))
       
(defun bysub3 (&rest filenames)
  (let ((msgs (make-array 0 :fill-pointer 0)))
    (dolist (filename filenames)
      (with-open-file (file filename)
        (loop
           for paragraph = (get-paragraph file)
           until (string-equal paragraph "")
           do 
           (when (scan (create-scanner #?r"^From" :multi-line-mode t) 
                       paragraph)
             (vector-push-extend
              (mkhash                   ; MKHASH defined in appendix
               :subject (register-groups-bind (subject)
                            ((create-scanner #?r/^Subject:\s*(?:Re:\s*)*(.*)/
                                             :case-insensitive-mode t :multi-line-mode t) paragraph)
                          (string-downcase subject))
               :number (fill-pointer msgs)
               :text "")
              msgs))
           (let ((mail-record (aref msgs (1- (fill-pointer msgs)))))
             (setf (gethash :text mail-record) (concatenate 'string (gethash :text mail-record) paragraph))))))
    (map nil #'(lambda (msg)
                 (format t "~A" (gethash :text msg)))
         (sort msgs #'(lambda (a b)
                        (let ((subject-a (gethash :subject a))
                              (subject-b (gethash :subject b)))
                          (case (cmp subject-a subject-b)
                            (0 (< (gethash :number a) (gethash :number b)))
                            (-1 t))))))))

;; Can be downloaded using ASDF-INSTALL
(require :metatilities)

(defun datesort (&rest filenames)
  (let ((msgs (make-array 0 :fill-pointer 0)))
    (dolist (filename filenames)
      (with-open-file (file filename)
        (loop
           for paragraph = (get-paragraph file)
           until (string-equal paragraph "")
           do 
           (when (scan (create-scanner #?r"^From" :multi-line-mode t) 
                       paragraph)
             (vector-push-extend
              (mkhash
               :subject (register-groups-bind (subject)
                            ((create-scanner #?r/^Subject:\s*(?:Re:\s*)*(.*)/
                                             :case-insensitive-mode t :multi-line-mode t) paragraph)
                          (string-downcase subject))
               :number (fill-pointer msgs)
               ;; Need IGNORE-ERRORS because PARSE-DATE-AND-TIME can
               ;; signal conditions
               :date (ignore-errors 
                       (metatilities:parse-date-and-time
                        (register-groups-bind (date)
                            ((create-scanner #?r/^Date:\s*(.*)/ :multi-line-mode t) paragraph)
                          (car (split #?r"\s+\(" date)))))
               :text "")
              msgs))
           (let ((mail-record (aref msgs (1- (fill-pointer msgs)))))
             (setf (gethash :text mail-record) (concatenate 'string (gethash :text mail-record) paragraph))))))
    (map nil #'(lambda (msg)
                 (format t "~A" (gethash :text msg)))
         (sort msgs #'(lambda (a b)
                        (case (cmp (gethash :subject a) (gethash :subject b))
                          (-1 t)
                          (0 (case (cmp (gethash :date a) (gethash :date b))
                               (-1 t)
                               (0 (< (gethash :number a) (gethash :number b)))))))))))