Skip to content

Commit

Permalink
clean up
Browse files Browse the repository at this point in the history
  • Loading branch information
@g000001
g000001 committed Mar 6, 2020
1 parent fa5f6a2 commit 8e1745e
Show file tree
Hide file tree
Showing 7 changed files with 131 additions and 164 deletions.
3 changes: 3 additions & 0 deletions .gitignore
View file
@@ -0,0 +1,3 @@
*.*~
*.*fasl
\#**\#
24 changes: 24 additions & 0 deletions LICENSE
View file
@@ -0,0 +1,24 @@
This is free and unencumbered software released into the public domain.

Anyone is free to copy, modify, publish, use, compile, sell, or
distribute this software, either in source code form or as a compiled
binary, for any purpose, commercial or non-commercial, and by any
means.

In jurisdictions that recognize copyright laws, the author or authors
of this software dedicate any and all copyright interest in the
software to the public domain. We make this dedication for the benefit
of the public at large and to the detriment of our heirs and
successors. We intend this dedication to be an overt act of
relinquishment in perpetuity of all present and future rights to this
software under copyright law.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.

For more information, please refer to <https://unlicense.org>
3 changes: 2 additions & 1 deletion README.org → README.md
View file
@@ -1,4 +1,5 @@
* SRFI 48: Intermediate Format Strings
# SRFI 48 for CL: Intermediate Format Strings

- Copyright (C) Kenneth A Dickey (2003). All Rights Reserved.

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, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
Expand Down
20 changes: 12 additions & 8 deletions package.lisp
View file
Expand Up @@ -2,14 +2,18 @@

(cl:in-package :cl-user)

(defpackage :srfi-48

(defpackage "https://github.com/g000001/srfi-48"
(:use)
(:export :format))
(:export format))


(defpackage "https://github.com/g000001/srfi-48#internals"
(:use cl fiveam)
(:shadow loop map member assoc)
(:shadowing-import-from "https://github.com/g000001/srfi-5" let)
(:shadowing-import-from "https://github.com/g000001/srfi-23" error)
(:shadowing-import-from "https://github.com/g000001/srfi-48" format))

(defpackage :srfi-48-internal
(:use :cl :fiveam)
(:shadow :loop :map :member :assoc)
(:shadowing-import-from :srfi-5 :let)
(:shadowing-import-from :srfi-23 :error)
(:shadowing-import-from :srfi-48 :format))

;;; *EOF*
40 changes: 32 additions & 8 deletions srfi-48.asd
View file
Expand Up @@ -2,18 +2,42 @@

(cl:in-package :asdf)


(defsystem :srfi-48
:version "20200307"
:description "SRFI 48 for CL: Intermediate Format Strings"
:long-description "SRFI 48 for CL: Intermediate Format Strings
https://srfi.schemers.org/srfi-48"
:author "Kenneth A Dickey"
:maintainer "CHIBA Masaomi"
:serial t
:depends-on (:srfi-1 :srfi-5 :srfi-23)
:components ((:file "package")
(:file "utils")
;;(:file "utils")
(:file "srfi-48")))


(defmethod perform :after ((o load-op) (c (eql (find-system :srfi-48))))
(let ((name "https://github.com/g000001/srfi-48")
(nickname :srfi-48))
(if (and (find-package nickname)
(not (eq (find-package nickname)
(find-package name))))
(warn "~A: A package with name ~A already exists." name nickname)
(rename-package name name `(,nickname)))))


(defmethod perform ((o test-op) (c (eql (find-system :srfi-48))))
(load-system :srfi-48)
(or (flet ((_ (pkg sym)
(intern (symbol-name sym) (find-package pkg))))
(let ((result (funcall (_ :fiveam :run) (_ :srfi-48-internal :srfi-48))))
(funcall (_ :fiveam :explain!) result)
(funcall (_ :fiveam :results-status) result)))
(error "test-op failed") ))
(let ((*package*
(find-package
"https://github.com/g000001/srfi-48#internals")))
(eval
(read-from-string
"
(or (let ((result (run 'srfi-48)))
(explain! result)
(results-status result))
(error \"test-op failed\") )"))))


;;; *EOF*
109 changes: 58 additions & 51 deletions srfi-48.lisp
View file
@@ -1,10 +1,9 @@
;;;; srfi-48.lisp

(cl:in-package :srfi-48-internal)
(cl:in-package "https://github.com/g000001/srfi-48#internals")

(def-suite srfi-48)
(def-suite* srfi-48)

(in-suite srfi-48)

;; IMPLEMENTATION DEPENDENT options

Expand Down Expand Up @@ -46,37 +45,38 @@
(defun compose-with-digits (digits pre-str frac-str exp-str)
(let ((frac-len (length frac-str)))
(cond
((< frac-len digits) ;; grow frac part, pad with zeros
(string-append pre-str "."
frac-str (make-string (- digits frac-len)
:initial-element #\0)
exp-str))
((= frac-len digits) ;; frac-part is exactly the right size
(string-append pre-str "."
frac-str
exp-str))
(:else ;; must round to shrink it
(let* ( (first-part (subseq frac-str 0 digits))
(last-part (subseq frac-str digits frac-len))
(temp-str
(write-to-string
(round (read-from-string
(string-append first-part "." last-part)))))
(dot-pos (string-index temp-str #\.))
(carry?
(and (> dot-pos digits)
(> (round (read-from-string
(string-append "0." frac-str)))
0)))
(new-frac
(subseq temp-str 0 digits)))
(string-append
(if carry?
(write-to-string (+ 1 (write-to-string pre-str)))
pre-str)
"."
new-frac
exp-str))))))
((< frac-len digits) ;; grow frac part, pad with zeros
(string-append pre-str "."
frac-str (make-string (- digits frac-len)
:initial-element #\0)
exp-str))
((= frac-len digits) ;; frac-part is exactly the right size
(string-append pre-str "."
frac-str
exp-str))
(:else ;; must round to shrink it
(let* ( (first-part (subseq frac-str 0 digits))
(last-part (subseq frac-str digits frac-len))
(temp-str
(write-to-string
(round (read-from-string
(string-append first-part "." last-part)))))
(dot-pos (string-index temp-str #\.))
(carry?
(and (> dot-pos digits)
(> (round (read-from-string
(string-append "0." frac-str)))
0)))
(new-frac
(subseq temp-str 0 digits)))
(string-append
(if carry?
(write-to-string (+ 1 (read-from-string pre-str)))
pre-str)
"."
new-frac
exp-str))))))


(defun format-fixed (number-or-string width digits) ; returns a string
(cond
Expand All @@ -86,7 +86,7 @@
(let ((real (realpart number-or-string))
(imag (imagpart number-or-string)))
(cond
((not (zero? imag))
((not (zerop imag))
(string-grow
(string-append (format-fixed real 0 digits)
(if (minusp imag) "" "+")
Expand Down Expand Up @@ -130,8 +130,13 @@
(format "FORMAT: ~F requires a number or a string, got ~s"
number-or-string))) ))

(setf (documentation 'format 'function)
"(format [<port>] <format-string> [<arg>...]) -- <port> is T, nil or an output-port
(defun require-an-arg (args)
(when (null args)
(error "FORMAT: too few arguments" )))


(defun format-doc ()
"(format [<port>] <format-string> [<arg>...]) -- <port> is T, nil or an output-port
OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Encoding
~H [Help] output this text
~A [Any] (display arg) for humans
Expand All @@ -151,11 +156,10 @@ OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Enc
~Y [Yuppify] the list arg is pretty-printed to the output
~? [Indirection] recursive format: next 2 args are format-string and list of arguments
~K [Indirection] same as ~?
" )
")

(defun require-an-arg (args)
(when (null args)
(error "FORMAT: too few arguments" )))
(setf (documentation 'format 'function)
(format-doc))

(defun format-help (format-strg arglist port)
(let ((length-of-format-string (length format-strg)))
Expand All @@ -172,9 +176,9 @@ OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Enc
(anychar-dispatch (+ pos 1) arglist nil))))))
(has-newline? (whatever last-was-newline)
(or (eql whatever #\newline)
(and (string? whatever)
(and (stringp whatever)
(let ( (len (length whatever)) )
(if (zero? len)
(if (zerop len)
last-was-newline
(eql #\newline
(char whatever (- len 1))))))))
Expand Down Expand Up @@ -282,7 +286,7 @@ OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Enc
(let ((width (read-from-string
(coerce (reverse w-digits)
'string)))
(digits (if (zero? (length d-digits))
(digits (if (zerop (length d-digits))
nil
(read-from-string
(coerce (reverse d-digits)
Expand All @@ -308,14 +312,14 @@ OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Enc
((< (length arglist) 2)
(error
(format "FORMAT: less arguments than specified for ~~?: ~s" arglist)))
((not (string? (car arglist)))
((not (stringp (car arglist)))
(error
(format "FORMAT: ~~? requires a string: ~s" (car arglist))))
(:else
(format-help (car arglist) (cadr arglist) port)
(anychar-dispatch (+ pos 1) (cddr arglist) nil))))
((#\H) ; Help
(princ (documentation 'format 'function) port)
(princ (format-doc) port)
(anychar-dispatch (+ pos 1) arglist T))
(otherwise
(error (format "FORMAT: unknown tilde escape: ~s"
Expand Down Expand Up @@ -365,15 +369,16 @@ OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Enc
(test format
(signals (cl:error)
(format))
(is (string= (format "~A" 'foo)
"FOO"))
(is (string-equal (format "~A" 'foo)
"FOO"))
(signals (cl:error)
(format nil))
(is (string= (format nil "~A" 'foo)
"FOO"))
(is (string-equal (format nil "~A" 'foo)
"FOO"))
;; H
(is (string= (format "~H")
(documentation 'format 'function)))
(or (documentation 'format 'function)
(format-doc))))
;; A
(is (string= (format "~A" '(1 2 3 4))
"(1 2 3 4)"))
Expand Down Expand Up @@ -431,3 +436,5 @@ OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Enc
;; K
(is (string= (format "~K" "~A~A~A" '(1 2 3))
"123")))

;;; *EOF*
96 changes: 0 additions & 96 deletions utils.lisp
View file

This file was deleted.

0 comments on commit 8e1745e

Please sign in to comment.