From 280bfe890dd9e854dfa2a3ba7b715283b1059bb7 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Wed, 5 Aug 2020 12:39:36 +0300 Subject: [PATCH] Improve presentation, clean up, add new things --- features.scm | 60 +++--------- foreign-status-property.scm | 59 ++++++++++++ foreign-status-set.scm | 29 ++++++ generate.scm | 181 ++++++++++++++++++++++++++++++++---- library-name.scm | 8 ++ machine.scm | 11 +++ operating-system.scm | 32 +++++++ reader-directive.scm | 54 +++++------ scheme-id.scm | 48 +++++----- 9 files changed, 363 insertions(+), 119 deletions(-) create mode 100644 foreign-status-property.scm create mode 100644 foreign-status-set.scm create mode 100644 library-name.scm create mode 100644 machine.scm create mode 100644 operating-system.scm diff --git a/features.scm b/features.scm index 5b518a2..46fb44d 100644 --- a/features.scm +++ b/features.scm @@ -3,58 +3,22 @@ ;; R7RS Standard Feature Identifiers (id r7rs) -(description "All R7RS Scheme implementations have this feature.") +(description "All R7RS Scheme implementations have this feature") (id exact-closed) -(description "The algebraic operations +, -, *, and expt where the second argument is a non-negative integer produce exactvalues given exact inputs.") +(description "The algebraic operations +, -, *, and expt (where the second argument is a non-negative integer) produce exact values given exact inputs") (id exact-complex) -(description "Exact complex numbers are provided.") +(description "Exact complex numbers are provided") (id ieee-float) -(description "Inexact numbers are IEEE 754 binary floating point values.") +(description "Inexact numbers are IEEE 754 binary floating point values") (id full-unicode) -(description "All Unicode characters present in Unicode version 6.0 are supported as Scheme characters.") +(description "All Unicode characters present in Unicode version 6.0 are supported as Scheme characters") (id ratios) -(description "/ with exact arguments produces an exact result when the divisor is nonzero.") - -(id posix) -(description "This implementation is running on a POSIX system.") - -(id windows) -(description "This implementation is running on Windows.") - -(id unix) -(description "Operating system flag") - -(id darwin) -(description "Operating system flag") - -(id gnu-linux) -(description "Operating system flag") - -(id bsd) -(description "Operating system flag") - -(id freebsd) -(description "Operating system flag") - -(id solaris) -(description "Operating system flag") - -(id i386) -(description "Running on a 32-bit Intel/AMD x86 processor.") - -(id x86-64) -(description "Running on a 64-bit AMD/Intel x86 processor.") - -(id ppc) -(description "Running on a PowerPC processor.") - -(id sparc) -(description "Running on a Sun SPARC processor.") +(description "/ with exact arguments produces an exact result when the divisor is nonzero") (id jvm) (description "Running on a Java Virtual Machine (JVM)") @@ -63,19 +27,19 @@ (description "Running on a Common Language Runtime (.NET CLR)") (id llvm) -(description "Running on the LLVM compiler infrastructure.") +(description "Running on the LLVM compiler infrastructure") (id ilp32) -(description "C language int, long and pointer types are all 32 bits wide.") +(description "C language int, long and pointer types are all 32 bits wide") (id lp64) -(description "C language int type is 32 bits, long and pointer 64 bits wide.") +(description "C language int type is 32 bits, long and pointer 64 bits wide") (id ilp64) -(description "C language int, long, and pointer types are all 64 its wide.") +(description "C language int, long, and pointer types are all 64 its wide") (id big-endian) -(description "The CPU byte order is big-endian.") +(description "The CPU byte order is big-endian") (id little-endian) -(description "The CPU byte order is little-endian.") +(description "The CPU byte order is little-endian") diff --git a/foreign-status-property.scm b/foreign-status-property.scm new file mode 100644 index 0000000..bda1b23 --- /dev/null +++ b/foreign-status-property.scm @@ -0,0 +1,59 @@ +(id set) +(description "Which set of status codes") +(type "symbol") + +(id code) +(description "Numeric or pseudo-numeric status code") +(type "exact integer or symbol") + +(id symbol) +(description "Mnemonic status identifier") +(type "symbol") + +(id message) +(description "Brief human-readable status message") +(type "string") + +(id message-locales) +(description "Languages in which message is available") +(type "list of BCP 47 strings") + +(id message-detail) +(description "Detailed human-readable status message") +(type "string") + +(id message-hint) +(description "Human-readable troubleshooting tips") +(type "string") + +(id filename) +(description "File that this status concerns") +(type "string") + +(id line-number) +(description "Line number in text") +(type "positive exact integer") + +(id column-number) +(description "Column number on this line of text") +(type "positive exact integer") + +(id sqlstate) +(description "5-character ANSI/ODBC SQLSTATE code") +(type "string") + +(id class-code) +(description "Numeric or pseudo-numeric code of the status class") +(type "exact integer or symbol") + +(id class-title) +(description "Human-readable name of the status class") +(type "string") + +(id facility) +(description "syslog-style facility") +(type "symbol") + +(id severity) +(description "syslog-style how severe the situation is") +(type "symbol") diff --git a/foreign-status-set.scm b/foreign-status-set.scm new file mode 100644 index 0000000..f1f589a --- /dev/null +++ b/foreign-status-set.scm @@ -0,0 +1,29 @@ +(id errno) +(description "C/POSIX/Unix errno values") + +(id ftp) +(description "File Transfer Protocol reply codes") + +(id http) +(description "Hypertext Transfer Protocol status codes") + +(id libsodium) +(description "The libsodium cryptography library") + +(id mysql) +(description "MySQL and MariaDB database errors") + +(id netdb) +(description "POSIX/Unix netdb.h error values") + +(id postgresql) +(description "PostgreSQL errors") + +(id sqlite) +(description "SQLite database result codes") + +(id windows) +(description "Microsoft Windows API (aka win32)") + +(id winsock) +(description "Microsoft Windows Sockets API ") diff --git a/generate.scm b/generate.scm index 58bd243..07e063f 100644 --- a/generate.scm +++ b/generate.scm @@ -1,4 +1,5 @@ (import (scheme base) (scheme file) (scheme read) (scheme write)) +(import (srfi 132)) (define (read-all) (let loop ((xs '())) @@ -15,14 +16,29 @@ (else (loop (cdr xs) gs (cons (car xs) g)))))) +(define (group-file head filename) + (group head (with-input-from-file filename read-all))) + +(define (assoc? key alist) + (let ((x (assoc key alist))) + (cond ((not x) #f) + ((and (list? x) (= 2 (length x))) (cadr x)) + (else (error "Nope"))))) + (define (assoc1 key alist) (let ((x (assoc key alist))) (if (and (list? x) (= 2 (length x))) (cadr x) (error "Nope")))) (define (display-sxml x) (define (display* . xs) (for-each display xs)) + (define (display-char char) + (let* ((cc (char->integer char)) + (ok? (case char ((#\& #\< #\> #\") #f) (else (<= #x20 cc #x7e))))) + (if ok? (display char) (display* "&#" cc ";")))) (define (display-attribute attribute) - (display* " " (car attribute) "=" "\"" (cdr attribute) "\"")) + (display* " " (car attribute) "=\"") + (string-for-each display-char (cadr attribute)) + (display "\"")) (cond ((pair? x) (display* "<" (car x)) (let ((body (cond ((and (pair? (cdr x)) @@ -35,35 +51,162 @@ (for-each display-sxml body) (display* ""))) ((string? x) - (display x)) - (else (error "Bad")))) + (string-for-each display-char x)) + (else (error "Bad:" x)))) + +;; + +(define (sort-by-id entries) + (list-sort (lambda (a b) + (stringstring (assoc1 'id a)) + (symbol->string (assoc1 'id b)))) + entries)) + +(define (classify class entries) + (map (lambda (entry) `((class ,class) ,@entry)) + entries)) + +(define (tabulate column-headings rows) + `(table (tr ,@(map (lambda (heading) `(th ,heading)) + column-headings)) + ,@(map (lambda (row) + (let ((class (car row)) + (tds (map (lambda (column) `(td ,column)) + (cdr row)))) + (if class `(tr (@ (class ,class)) ,@tds) + `(tr ,@tds)))) + rows))) ;; (define (scheme-id) - `((h2 "Scheme ID") - (table - (tr - (th "ID") - (th "Title") - (th "Contact")) - ,@(map (lambda (entry) - `(tr (td (code ,(symbol->string (assoc1 'id entry)))) - (td ,(assoc1 'title entry)) - (td ,(assoc1 'contact entry)))) - (group 'id (with-input-from-file "scheme-id.scm" read-all)))))) + `((h2 "Scheme implementations") + (p "Scheme IDs for use in " + (code "features") ", " (code "cond-expand") ", and many other places.") + ,(tabulate + '("ID" "Name" "Contact") + (map (lambda (entry) + (cons #f + `((code ,(symbol->string (assoc1 'id entry))) + ,(assoc1 'description entry) + ,(assoc1 'contact entry)))) + (group-file 'id "scheme-id.scm"))))) + +(define (operating-system) + `((h2 "Operating systems") + ,(tabulate + '("ID" "Description") + (map (lambda (entry) + (cons #f + `((code ,(symbol->string (assoc1 'id entry))) + ,(assoc1 'description entry)))) + (group-file 'id "operating-system.scm"))))) + +(define (machine) + `((h2 "Machines") + ,(tabulate + '("ID" "Description") + (map (lambda (entry) + (cons #f + `((code ,(symbol->string (assoc1 'id entry))) + ,(assoc1 'description entry)))) + (group-file 'id "machine.scm"))))) + +(define (splice-implementations) + (map (lambda (entry) + `((id ,(assoc1 'id entry)) + (description ,(assoc1 'description entry)))) + (group-file 'id "scheme-id.scm"))) + +(define (feature) + `((h2 "Feature identifiers") + ,(tabulate + '("ID" "Description") + (map (lambda (entry) + (cons (assoc? 'class entry) + `((code ,(symbol->string (assoc1 'id entry))) + ,(assoc1 'description entry)))) + (sort-by-id + (append (group-file 'id "features.scm") + (classify "red" + (splice-implementations)) + (classify "green" + (group-file 'id "operating-system.scm")) + (classify "blue" + (group-file 'id "machine.scm")))))))) + +(define (library-name) + `((h2 "Library name prefixes") + ,(tabulate + '("ID" "Description") + (map (lambda (entry) + (cons (assoc? 'class entry) + `((code ,(symbol->string (assoc1 'id entry))) + ,(assoc1 'description entry)))) + (sort-by-id + (append (group-file 'id "library-name.scm") + (classify "red" (splice-implementations)))))))) + +(define (reader-directive) + `((h2 "Reader directives") + ,(tabulate + '("ID" "Description" "Prefixes") + (map (lambda (entry) + (cons (assoc? 'class entry) + `((code ,(symbol->string (assoc1 'id entry))) + ,(assoc1 'description entry) + (code ,(assoc1 'prefixes entry))))) + (sort-by-id + (append (group-file 'id "reader-directive.scm"))))))) + +(define (foreign-status-set) + `((h2 "Foreign status sets") + ,(tabulate + '("ID" "Description") + (map (lambda (entry) + (cons #f + `((code ,(symbol->string (assoc1 'id entry))) + ,(assoc1 'description entry)))) + (group-file 'id "foreign-status-set.scm"))))) + +(define (foreign-status-property) + `((h2 "Foreign status properties") + ,(tabulate + '("ID" "Description" "Type") + (map (lambda (entry) + (cons #f + `((code ,(symbol->string (assoc1 'id entry))) + ,(assoc1 'description entry) + ,(assoc1 'type entry)))) + (group-file 'id "foreign-status-property.scm"))))) (define (display-page) + (display "") (display-sxml `(html (head - (title "Scheme registry") - (style "body { font-family: sans-serif; }" + (title "Scheme Registry") + (style "" + "body { font-family: sans-serif; background-color: beige; }" + "body { max-width: 40em; }" + "table { border-collapse: collapse; }" "table, th, td { border: 1px solid black; }" - "table { border-collapse: collapse; }")) + "th, td { vertical-align: top; padding: 2px; }" + "code { white-space: nowrap; }" + "tr.red td { background-color: sandybrown; }" + "tr.green td { background-color: lightgreen; }" + "tr.blue td { background-color: lightblue; }" + )) (body - (h1 "Scheme registry") + (h1 "Scheme Registry") (p "The Scheme registry collects identifiers.") - ,@(scheme-id))))) + ,@(scheme-id) + ,@(operating-system) + ,@(machine) + ,@(feature) + ,@(library-name) + ,@(reader-directive) + ,@(foreign-status-set) + ,@(foreign-status-property))))) (with-output-to-file "index.html" display-page) diff --git a/library-name.scm b/library-name.scm new file mode 100644 index 0000000..4a41852 --- /dev/null +++ b/library-name.scm @@ -0,0 +1,8 @@ +(id rnrs) +(description "Standard Scheme (R6RS and up)") + +(id scheme) +(description "Standard Scheme (R7RS and up)") + +(id srfi) +(description "Scheme Requests for Implementation") diff --git a/machine.scm b/machine.scm new file mode 100644 index 0000000..6346ec3 --- /dev/null +++ b/machine.scm @@ -0,0 +1,11 @@ +(id i386) +(description "32-bit Intel/AMD x86 processor") + +(id x86-64) +(description "64-bit AMD/Intel x86 processor") + +(id ppc) +(description "PowerPC processor") + +(id sparc) +(description "Sun SPARC processor") diff --git a/operating-system.scm b/operating-system.scm new file mode 100644 index 0000000..f20e625 --- /dev/null +++ b/operating-system.scm @@ -0,0 +1,32 @@ +(id bsd) +(description "An operating system in the BSD Unix family") + +(id darwin) +(description "Darwin-based (Apple macOS X, iOS) operating system") + +(id dragonfly) +(description "The DragonFlyBSD operating system") + +(id freebsd) +(description "The FreeBSD operating system") + +(id gnu-linux) +(description "A GNU/Linux distribution") + +(id netbsd) +(description "The NetBSD operating system") + +(id openbsd) +(description "The OpenBSD operating system") + +(id posix) +(description "This implementation is running on a POSIX system") + +(id solaris) +(description "The Solaris/SunOS operating system") + +(id unix) +(description "Unix-like operating system") + +(id windows) +(description "Microsoft Windows operating system") diff --git a/reader-directive.scm b/reader-directive.scm index dccbb2f..41fa8a6 100644 --- a/reader-directive.scm +++ b/reader-directive.scm @@ -1,35 +1,35 @@ -(directive "#!bwp") -(purpose "broken-weak-pair object") -(implementations chezscheme) +(id bwp) +(description "broken-weak-pair object") +(prefixes "#!") -(directive "#!eof") -(purpose "end-of-file object") -(implementations chezscheme chicken gambit) +(id eof) +(description "end-of-file object") +(prefixes "#!") -(directive "#!fold-case") -(purpose "change to case insensitive identifiers") -(rnrs r7rs) +(id fold-case) +(description "change to case insensitive identifiers") +(prefixes "#!") -(directive "#!key") -(purpose "start keyword arguments in lambda list") -(srfi 89) +(id key) +(description "start keyword arguments in lambda list") +(prefixes "#!") -(directive "#!no-fold-case") -(purpose "change to case sensitive identifiers") -(rnrs r7rs) +(id no-fold-case) +(description "change to case sensitive identifiers") +(prefixes "#!") -(directive "#!optional") -(purpose "start optional arguments in lambda list") -(srfi 89) +(id optional) +(description "start optional arguments in lambda list") +(prefixes "#!") -(directive "#!r6rs") -(purpose "change to R6RS read syntax") -(rnrs r6rs) +(id r6rs) +(description "change to R6RS read syntax") +(prefixes "#!") -(directive "#!r7rs") -(purpose "change to R7RS read syntax") -(implementations gauche) +(id r7rs) +(description "change to R7RS read syntax") +(prefixes "#!") -(directive "#!rest") -(purpose "start rest argument in lambda list") -(srfi 89) +(id rest) +(description "start rest argument in lambda list") +(prefixes "#!") diff --git a/scheme-id.scm b/scheme-id.scm index 53415ac..12f4ed7 100644 --- a/scheme-id.scm +++ b/scheme-id.scm @@ -1,93 +1,91 @@ -;;; Scheme implementation identifiers - (id bigloo) -(title "Bigloo") +(description "Bigloo") (contact "Manuel Serrano") (id chezscheme) -(title "Chez Scheme") +(description "Chez Scheme") (contact "Kent Dybvig") (id chibi) -(title "Chibi-Scheme") +(description "Chibi-Scheme") (contact "Alex Shinn") (id chicken) -(title "CHICKEN") +(description "CHICKEN") (contact "Felix Winkelmann") (id cyclone) -(title "Cyclone") +(description "Cyclone") (contact "Justin Ethier") (id gambit) -(title "Gambit Scheme") +(description "Gambit Scheme") (contact "Marc Feeley") (id gauche) -(title "Gauche") +(description "Gauche") (contact "Shiro Kawai") (id gerbil) -(title "Gerbil Scheme") +(description "Gerbil Scheme") (contact "Dimitris Vyzovitis") (id guile) -(title "GNU Guile") +(description "GNU Guile") (contact "Andy Wingo") (id ikarus) -(title "Ikarus Scheme") +(description "Ikarus Scheme") (contact "Abdulaziz Ghuloum") (id ironscheme) -(title "IronScheme") +(description "IronScheme") (contact "Llewellyn Pritchard") (id jazz) -(title "JazzScheme") +(description "JazzScheme") (contact "Guillaume Cartier") (id kawa) -(title "Kawa") +(description "Kawa") (contact "Per Bothner") (id larceny) -(title "Larceny") +(description "Larceny") (contact "William Clinger") (id loko) -(title "Loko Scheme") +(description "Loko Scheme") (contact "Göran Weinholt") (id mit) -(title "MIT Scheme") +(description "MIT Scheme") (contact "Chris Hanson") (id picrin) -(title "Picrin") +(description "Picrin") (contact "Yuichi Nishiwaki") (id s7) -(title "s7") +(description "s7") (contact "Bill Schottstaedt") (id s9fes) -(title "Scheme 9 from Empty Space") +(description "Scheme 9 from Empty Space") (contact "Nils Holm") (id sagittarius) -(title "Sagittarius Scheme") +(description "Sagittarius Scheme") (contact "Takashi Kato") (id sigscheme) -(title "SigScheme") +(description "SigScheme") (contact "Kazuki Ohta") (id stklos) -(title "STklos") +(description "STklos") (contact "Erick Gallesio") (id ypsilon) -(title "Ypsilon") +(description "Ypsilon") (contact "Yoshikatsu Fujita")